VBA下载，提取并导入到Excel 2007

Question

有人可以为我量身定做这个脚本吗？我在原始问题（26486871）中寻求帮助，但我的请求已被删除。

此脚本完成我所需的工作：从公共网站下载zip文件，提取文件...并将数据导入工作表。

不过，我有2个例外：

1. 有一个在邮政编码csv文件。它只包含一个文本文件（20MB）。
2. 我不想要新的工作表。我想覆盖以前导入工作表中的现有数据。

我此脚本修修补补2天，但它卡住在以下方面：

“运行时错误‘3001’：参数的错误类型，超出可接受的范围内，或相互冲突。“

该错误，脚本编辑器指向Stream.SaveToFile的TargetFile，1'1 =无覆盖，2 =覆盖

如果有差别，压缩的文本文件，具有标签空格分开的数据对齐文本到列。

我想感谢Miguel Febres开发此脚本。

我将不胜感激任何帮助。

---

'Main Procedure 
Sub DownloadAndLoad() 

    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://www.example.com/data.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 targetFile, 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 

End Function  

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

喜布鲁斯看以下。它应该解决你的下载问题。

'' This function downloads a file from a given webpage named 'url' and copies it to 'copylocation' named as 'filename'. 
'' It is vital to check which format does the content has. For example: xlsx, csv, txt etc. This must be determined in 'downloadformat'. 
'' If an already existing file should be overwriten, then overwritefile = TRUE must be set. 
'' 
'' Example of use: GetWebpageContent("http://www.snb.ch/n/mmr/tcoreference/Current%20Rates/Interest_Rates/source/interest_rates.xlsx", 
''    "F:\public\CurrentMarketRates", 
''    "SARM", "xlsx", TRUE) 
'' 
Function GetWebpageContent(url As String, copylocation As String, filename As String, downloadformat As String, overwritefile As Boolean) As Boolean 
    Dim WinHttpReq As Object, fname As String, res As Boolean 
    Dim owritef As Integer 
     owritef = 1 
    ''do not overwrite, unless overwritefile = TRUE 
    If overwritefile Then 
     owritef = 2 
    End If 
    ''create filename and location 
    res = True 
    fname = "\" & filename & "_" & Year(Now) & "." & downloadformat 

    Set WinHttpReq = CreateObject("Microsoft.XMLHTTP") 
    WinHttpReq.Open "GET", url, False 
    WinHttpReq.Send 

    If WinHttpReq.Status = 200 Then 
     Set oStream = CreateObject("ADODB.Stream") 
     oStream.Open 
     oStream.Type = 1 
     oStream.Write WinHttpReq.responseBody 
     oStream.SaveToFile copylocation & fname, 2 ' 1 = no overwrite, 2 = overwrite 
     oStream.Close 
    End If 

    GetWebpageContent = res 
End Function