从网上下载Zip文件（包含.csv）到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) & "" 

    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文件夹的内容，但档案中的实际文件名（S）为未命名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 

我不知道为什么要添加额外的圆括号，但是我无法在没有它的情况下提取文件。