从网站下载Zip文件（包含.csv）到excel VBA
我偶然发现了这个代码，但是我很难让它工作。 我试图从网站上下载一个包含.csv的zip文件，并把内容放到我的excel文件中。 我目前被困在这一行：
'3 rename file Name targetFileCSV As targetFileTXT 它说，它无法find该文件。
任何帮助表示赞赏！
'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
这是因为您正在提取.zip文件夹的内容，但该归档中的实际文件名不是名为data.csv （这是您要重命名，但该文件不存在）。 当我运行代码时，该.zip压缩文件中的文件被命名为00260008-eng.csv 。
您需要重新命名提取的文件，或者在解压缩后查找没有.zip文件。
删除这一行：
targetFileCSV = targetFolder & "data.csv"
并在1, 2, 3添加新行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
我不知道为什么添加额外的圆括号，但是如果没有它，我就无法提取文件。