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

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

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

1 个答案: