将 Zip 文件（包含 .csv）从 Web 下载到 excel VBA

Question

我偶然发现了这段代码，但我很难让它工作。我正在尝试从网站下载包含 .csv 的 zip 文件并将内容放入我的 excel 文件中。我目前卡在这条线上：

'3 rename file
Name targetFileCSV As targetFileTXT

它说找不到文件。

感谢任何帮助！

'Main Procedure
Sub LETSDOTHIS()

    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://www20.statcan.gc.ca/tables-tableaux/cansim/csv/00260008-eng.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 target, 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

'    Call UnZip(targetFolder, targetFileZip)


End Function

Private Sub UnZips(mainFolder As Variant, zipFolder As Variant)


    Call UnZip(targetFolder, targetFileZip)


End Sub


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 1

这是因为您正在提取 .zip 文件夹的内容，但该存档中的实际文件名未命名为 data.csv（这是您要重命名的名称，但该文件没有存在）。当我运行代码时，.zip 存档中的文件被命名为 00260008-eng.csv。

解压后需要重命名解压的文件或查找其中没有.zip的文件。

删除这一行：

targetFileCSV = targetFolder & "data.csv"

并在您的 1, 2, 3 中添加一个新行，以便您可以从 .zip 存档中获取您拥有的第一个 CSV 文件。

'1 download file
DownloadFile url, targetFileZip

'2 extract contents
Call UnZip(targetFileZip, targetFolder)

'3 rename file
targetFileCSV = targetFolder & Dir(targetFolder & "\*.csv")
Name targetFileCSV As targetFileTXT

另外，如果其他人在代码示例中运行 #2 时遇到问题，请添加一些额外的括号。

' Added extra parentheses
objOApp.Namespace((FileNameToUnzip)).CopyHere objOApp.Namespace((varFileNameFolder)).items, 24

我不知道为什么添加额外的括号有效，但没有它我无法提取文件。