從網上下載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 

我不知道爲什麼要添加額外的圓括號，但是我無法在沒有它的情況下提取文件。