Question

我有一个简单的链接www.example.com/file.zip

里面有一个csv文件

下载文件不需要登录表单，它是直接链接。

有没有办法将文件下载到临时文件夹，将其解压缩，然后作为新工作表导入现有工作表？（全部通过一键VBA）

Answer 1

尝试以下代码。它使用Windows中内置的zip功能并正确加载CSV文件是将文件重命名为TXT所必需的。

'Main Procedure
Sub DownloadAndLoad()

    Dim url As String
    Dim targetFolder As String, targetFileZip As String, targetFileCSV As String, targetFileTXT As String

    Dim wkbAll As Workbook
    Dim wkbTemp As Workbook
    Dim sDelimiter As String
    Dim newSheet As Worksheet

    url = "http://www.example.com/data.zip"
    targetFolder = Environ("TEMP") & "\" & RandomString(6) & "\"
    MkDir targetFolder
    targetFileZip = targetFolder & "data.zip"
    targetFileCSV = targetFolder & "data.csv"
    targetFileTXT = targetFolder & "data.txt"

    '1 download file
    DownloadFile url, targetFileZip

    '2 extract contents
    Call UnZip(targetFileZip, targetFolder)

    '3 rename file
    Name targetFileCSV As targetFileTXT

    '4 Load data
    Call LoadFile(targetFileTXT)

End Sub

Private Sub DownloadFile(myURL As String, target As String)

    Dim WinHttpReq As Object
    Set WinHttpReq = CreateObject("Microsoft.XMLHTTP")
    WinHttpReq.Open "GET", myURL, False
    WinHttpReq.send

    myURL = WinHttpReq.responseBody
    If WinHttpReq.Status = 200 Then
        Set oStream = CreateObject("ADODB.Stream")
        oStream.Open
        oStream.Type = 1
        oStream.Write WinHttpReq.responseBody
        oStream.SaveToFile targetFile, 2  ' 1 = no overwrite, 2 = overwrite
        oStream.Close
    End If

End Sub


Private Function RandomString(cb As Integer) As String

    Randomize
    Dim rgch As String
    rgch = "abcdefghijklmnopqrstuvwxyz"
    rgch = rgch & UCase(rgch) & "0123456789"

    Dim i As Long
    For i = 1 To cb
        RandomString = RandomString & Mid$(rgch, Int(Rnd() * Len(rgch) + 1), 1)
    Next

End Function

Private Function UnZip(PathToUnzipFileTo As Variant, FileNameToUnzip As Variant)
    ' Unzips a file
    ' Note that the default OverWriteExisting is true unless otherwise specified as False.
    Dim objOApp As Object
    Dim varFileNameFolder As Variant
    varFileNameFolder = PathToUnzipFileTo
    Set objOApp = CreateObject("Shell.Application")
    ' the "24" argument below will supress any dialogs if the file already exist. The file will
    ' be replaced. See http://msdn.microsoft.com/en-us/library/windows/desktop/bb787866(v=vs.85).aspx
    objOApp.Namespace(FileNameToUnzip).CopyHere objOApp.Namespace(varFileNameFolder).items, 24

End Function


Private Sub LoadFile(file As String)

     Set wkbTemp = Workbooks.Open(Filename:=file, Format:=xlCSV, Delimiter:=";", ReadOnly:=True)

     wkbTemp.Sheets(1).Cells.Copy
     'here you just want to create a new sheet and paste it to that sheet
     Set newSheet = ThisWorkbook.Sheets.Add
     With newSheet
         .Name = wkbTemp.Name
         .PasteSpecial
     End With
     Application.CutCopyMode = False
     wkbTemp.Close

End Sub

Answer 2

你可以在那里用简单的代码找到它：

Download a File with VBA

Unzip Files

并使用此Sub将文件数据导入新工作表。

Sub InsertCSVData()
    Sheets.Add After:=Sheets(Sheets.Count)
    With ActiveSheet.QueryTables.Add(Connection:= _
        "TEXT;C:\Ttemp\filename.csv", Destination:=Range("$B$7"))
        .Name = "filename"
        .FieldNames = True
        .RowNumbers = False
        .PreserveFormatting = True
        .RefreshStyle = xlInsertDeleteCells
        .SaveData = True
        .AdjustColumnWidth = True
        .TextFilePlatform = xlWindows
        .TextFileStartRow = 1
        ' Don't forget to choose your delimiters and text type.
        .TextFileParseType = xlDelimited
        .TextFileTextQualifier = xlTextQualifierNone
        .TextFileConsecutiveDelimiter = False
        .TextFileTabDelimiter = False
        .TextFileSemicolonDelimiter = True
        .TextFileCommaDelimiter = False
        .TextFileSpaceDelimiter = False
        .TextFileTrailingMinusNumbers = True
        .Refresh BackgroundQuery:=False
    End With
End Sub

希望有所帮助。

如何将在线托管的压缩csv导入Excel

2 个答案: