Office: (Office 365) Makro Zip-Datei von Webseite runterladen, auspacken, kopieren

Hallo Zusammen,

ich habe ein Makro gefunden von dem ich denke, dass es koennen sollte was ich braeuchte, eine Datei herunterladen, auspacken und den Inhalt in die Datei kopieren in der das Makro gestartet wird. Wenn ich den Link eingebe kommt Datei nicht gefunden, oder es stoppt in der Zeile Csvfile. Weiter bin ich noch nicht gekommen, weil ich nicht weiss, was der Fehler ist.

Sub DownloadZipExtractCsvAndLoad_01()
'ZVI:2017-01-07 Need vba to download and copy the data from zip file
'ZVI:2018-09-11 Updated code with destination range constants

' --> User settings, change to suit
Const DestSheet = "F_X-Rates"
Const DestCell = "C4"
'<-- End of the user settings

Dim UrlFile As String, ZipFile As String, CsvFile As String, Folder As String, s As String, DestWorkbook As String

' UrlFile to the ZIP archive with CSV file
UrlFile = "https://www.ecb.europa.eu/stats/eurofxref/eurofxref-hist.zip?2baf28632f50dcbc1dc5a7c2328464fd"

' Extract ZipFile, CsvFile from UrlFile
ZipFile = Mid(UrlFile, InStrRev(UrlFile, "/") + 1)
CsvFile = Left(ZipFile, Len(ZipFile) - 4)

' Define temporary folder (updated 2018-09-11)
Folder = Environ("TEMP")
If Right(Folder, 1) <> "\" Then Folder = Folder & "\"

' Disable screen updating to avoid blinking
Application.ScreenUpdating = False

' Trap errors
On Error GoTo exit_

' Download UrlFile to ZipFile in Folder
If Not Url2File(UrlFile, Folder & ZipFile) Then
MsgBox "Can't download file" & vbLf & UrlFile, vbCritical, "Error"
Exit Sub
End If

' Extract CsvFile from ZipFile
If Len(Dir(Folder & CsvFile)) Then Kill Folder & CsvFile
With CreateObject("Shell.Application").Namespace((Folder))
.CopyHere Folder & ZipFile & "\" & CsvFile
End With
Kill Folder & ZipFile

' Delete temporary folders to prevent saturation of Shell.Application
With CreateObject("Scripting.FileSystemObject")
s = Dir(Folder & "\*" & ZipFile, vbDirectory + vbHidden)
While Len(s)
.DeleteFolder Folder & s, True
s = Dir()
Wend
End With

' Import CsvFile to Excel
With Workbooks.Open(Folder & CsvFile).Sheets(1)
.UsedRange.Columns(1).TextToColumns Destination:=.Cells(1), DataType:=xlDelimited, _
TextQualifier:=xlDoubleQuote, ConsecutiveDelimiter:=False, Tab:=False, _
Semicolon:=False, Comma:=True, Space:=False, Other:=False, _
FieldInfo:=Array(Array(3, 4), Array(15, 4)), TrailingMinusNumbers:=True
' Autofit the widths
.UsedRange.Columns.AutoFit

' Copy sheet to the new workbook
'.Copy

' Copy data to the destination range (updated 2018-09-11)
.UsedRange.Copy Workbooks(DestWorkbook).Sheets(DestSheet).Range(DestCell)

' Release (close) CsvFile
.Parent.Close False
End With

' Delete CsvFile
Kill Folder & CsvFile

exit_:

' Restore screen updating
Application.ScreenUpdating = True

' Inform about the reason of the trapped error
If Err Then MsgBox Err.Description, vbCritical, "Error"

End Sub

Function Url2File(UrlFile As String, PathName As String, Optional Login As String, Optional Password As String) As Boolean
'ZVI:2017-01-07 Download UrlFile and save it to PathName.
' Use optional Login and Password if required.
' Returns True on success downloading.
Dim b() As Byte, FN As Integer
On Error GoTo exit_
If Len(Dir(PathName)) Then Kill PathName
With CreateObject("MSXML2.XMLHTTP")
.Open "GET", UrlFile, False, Login, Password
.send
If .Status <> 200 Then Exit Function
b() = .responseBody
FN = FreeFile
Open PathName For Binary Access Write As FN
Put FN, , b()
exit_:
If FN Then Close FN
Url2File = .Status = 200
End With
End Function

Kann es sein, dass die obige Version nicht auf Excel 365 laeuft? Ich kann auf den Temp- Ordner nicht zugreifen, falls es daran liegt.

Beste Gruesse
Matthias

 

Hallo
Mein Tipp:
Lade dir deine Zip Datei über deinen Browser herunter und entpacke sie, anschließend importiere deine csv. Dateien mit Power Query und bearbeite sie nach Wunsch.
Dies funktioniert ganz prima von deinem gezeigten Link, dazu brauchst du kein VBA.

 

Hallo,

Ich nehme an, dass du folgende Zeile in das Makro hineinkopiert hast:
UrlFile = "https://www.ecb.europa.eu/stats/eurofxref/eurofxref-hist.zip?2baf28632f50dcbc1dc5a7c2328464fd"
um damit die Inhalte der Zip-Datei in ein Excel-Arbeitsblatt zu kopieren. Was du nicht bedacht hast, dass dieser URL sich aus mehreren Bestandteilen zusammensetzt:
https:// bezeichnet das Protokoll,
www.ecb.europa.eu bezeichnet die Hierarchie der Domains
/stats/eurofxref/ den Pfad in vorgenannter www.ecb-Domain
eurofxref-hist.zip die dort vorhandene Zip-Datei
?2baf28632f50dcbc1dc5a7c2328464fd einen Abfrageparameter für die Zip-Datei.

Du hast aber den Abfrageparameter als Bestandteil des Zip- und Csv-Dateinamens belassen, was so nicht funktionieren konnte.

Ich habe das Makro an mehreren Stellen ergänzt:
1) Ich habe der Variablen "DestWorkbook" den Namen der Arbeitsmappe zugewiesen, die dieses Makro enthält:
DestWorkbook = ThisWorkbook.Name
Dabei muss aber auch in dieser Arbeitsmappe ein Arbeitsblatt mit dem Namen "F_X-Rates" existieren, in welches die Daten kopiert werden.

2) Ich habe getestet, ob der URL ein ?-Zeichen enthält und entsprechend den Zip- u. Csv-Dateinamen modifiziert:

Code:

   posQuest = InStr(ZipFile, "?")                        

   If posQuest Then ZipFile = Left(ZipFile, posQuest - 1)
 
   If LCase$(Right(ZipFile, 4)) = ".zip" Then            
      CsvFile = Left(ZipFile, Len(ZipFile) - 4) & ".csv"    
   Else                                                      
      CsvFile = ZipFile & ".csv"                            
   End If           

3) Ich habe an folgender Stelle den Pfad korrigiert:
s = Dir(Folder & ZipFile, vbDirectory + vbHidden)

Nachfolgend nochmals das gesamte Makro:

Code:

Sub DownloadZipExtractCsvAndLoad_01()
   'ZVI:2017-01-07 Need vba to download and copy the data from zip file
   'ZVI:2018-09-11 Updated code with destination range constants
  
   ' --> User settings, change to suit
   Const DestSheet = "F_X-Rates"
   Const DestCell = "C4"
   '<-- End of the user settings
  
   Dim UrlFile As String, ZipFile As String, CsvFile As String, Folder As String, s As String, DestWorkbook As String
   Dim posQuest As Long
  
   ' UrlFile to the ZIP archive with CSV file
   UrlFile = "https://www.ecb.europa.eu/stats/eurofxref/eurofxref-hist.zip?2baf28632f50dcbc1dc5a7c2328464fd"
  
   ' Name der Arbeitsmappe, in der sich dieses Makro befindet '<===(updated 2024-04-13)
   DestWorkbook = ThisWorkbook.Name                           '<===
  
   ' Extract ZipFile, CsvFile from UrlFile
   ZipFile = Mid(UrlFile, InStrRev(UrlFile, "/") + 1)
   posQuest = InStr(ZipFile, "?")                             '<===(updated 2024-04-13)
   If posQuest Then ZipFile = Left(ZipFile, posQuest - 1)     '<===
  
   If LCase$(Right(ZipFile, 4)) = ".zip" Then                 '<===
      CsvFile = Left(ZipFile, Len(ZipFile) - 4) & ".csv"      '<===
   Else                                                       '<===
      CsvFile = ZipFile & ".csv"                              '<===
   End If                                                     '<===
  
   ' Define temporary folder (updated 2018-09-11)
   Folder = Environ("TEMP")
   If Right(Folder, 1) <> "\" Then Folder = Folder & "\"
  
   ' Disable screen updating to avoid blinking
   Application.ScreenUpdating = False
  
   ' Trap errors
   On Error GoTo exit_
  
   ' Download UrlFile to ZipFile in Folder
   If Not Url2File(UrlFile, Folder & ZipFile) Then
      MsgBox "Can't download file" & vbLf & UrlFile, vbCritical, "Error"
      Exit Sub
   End If
  
   ' Extract CsvFile from ZipFile
   If Len(Dir(Folder & CsvFile)) Then Kill Folder & CsvFile
   With CreateObject("Shell.Application").Namespace((Folder))
      .CopyHere Folder & ZipFile & "\" & CsvFile
   End With
   Kill Folder & ZipFile
  
   ' Delete temporary folders to prevent saturation of Shell.Application
   With CreateObject("Scripting.FileSystemObject")
      s = Dir(Folder & ZipFile, vbDirectory + vbHidden)    '<===(updated 2024-04-13) kein "\*" !
      While Len(s)
         .DeleteFolder Folder & s, True
         s = Dir()
      Wend
   End With
  
   ' Import CsvFile to Excel
   With Workbooks.Open(Folder & CsvFile).Sheets(1)
      .UsedRange.Columns(1).TextToColumns Destination:=.Cells(1), DataType:=xlDelimited, _
            TextQualifier:=xlDoubleQuote, ConsecutiveDelimiter:=False, Tab:=False, _
            Semicolon:=False, Comma:=True, Space:=False, Other:=False, _
            FieldInfo:=Array(Array(3, 4), Array(15, 4)), TrailingMinusNumbers:=True
      ' Autofit the widths
      .UsedRange.Columns.AutoFit
    
      ' Copy sheet to the new workbook
      '.Copy
    
      ' Copy data to the destination range (updated 2018-09-11)
      .UsedRange.Copy Workbooks(DestWorkbook).Sheets(DestSheet).Range(DestCell)
    
      ' Release (close) CsvFile
      .Parent.Close False
   End With
  
   ' Delete CsvFile
   Kill Folder & CsvFile
  
exit_:
  
   ' Restore screen updating
   Application.ScreenUpdating = True
  
   ' Inform about the reason of the trapped error
   If Err Then MsgBox Err.Description, vbCritical, "Error"

End Sub

Function Url2File(UrlFile As String, PathName As String, Optional Login As String, Optional Password As String) As Boolean
   'ZVI:2017-01-07 Download UrlFile and save it to PathName.
   ' Use optional Login and Password if required.
   ' Returns True on success downloading.
   Dim b() As Byte, FN As Integer
   On Error GoTo exit_
   If Len(Dir(PathName)) Then Kill PathName
   With CreateObject("MSXML2.XMLHTTP")
      .Open "GET", UrlFile, False, Login, Password
      .send
      If .Status <> 200 Then Exit Function
      b() = .responseBody
      FN = FreeFile
      Open PathName For Binary Access Write As FN
      Put FN, , b()
exit_:
      If FN Then Close FN
      Url2File = .Status = 200
   End With
End Function

 

Hallo Anton Exl,
super vielen Dank. Das werde ich sofort ausprobieren.
Beste Gruesse und einen schoenen Sonntag noch.
Matthias

 

Funktioniert mit dem Herunterladen. Ich hätte noch zwei Fragen unten. Zu deinen Anmerkungen:
Zu 1) Ja, ein Arbeitsblatt mit dem Namen oder ggf. anderem Namen entsprechend dem was von der EZB kommt habe ich eingefügt. Danke für den Hinweis und die Aenderung.
zu 2) Enthaelt die URL ein Fragezeichen? Hintergrund der Frage ist, dass sich die URL zu verschiedenen Zeiten zu ändern scheint und ich versucht habe es zu verallgemeinern. In Excel in einer Zelle die URL vom ? bis zum Ende durch &"*" ersetzt und angeklickt lädt die Datei herunter, aber im Makro so eingefügt funktioniert es nicht. Auf der Ursprungsseite gab es zu ändernden URL's noch dies hier:
"
UrlFile = "https://www.nseindia.com/content/EQUITIES/" & [TEXT(NOW(),"YYYY/MMM/c\mDDMMMYYYY")] & "bhav.csv.zip""
bzw. das "
Dim MonthName As String
MonthName = [TEXT(NOW(),"MMM")]
UrlFile = "https://www.nseindia.com/content/EQUITIES/" & [TEXT(NOW(),"YYYY/MMM/c\mDDMMMYYYY")] & "bhav.csv.zip"
UrlFile = Replace(UrlFile, MonthName, UCase(MonthName))"
Ist es moeglich den Link so zu aendern, dass man nicht auf die Seite gehen muss um ihn zu kopieren?
Zu 3) War die Korrektur um es an den Teil Extract Csvfile from Zipfile mit dem Ordner anzupassen?

Gibt es in dem Makro einen Teil der sich auf das amerikanische Datumssystem Monat/Tag bezieht? Die Datei der EZB zeigt das Datum Tag/Monat/Jahr an. Nachdem kopieren kommt bei mir Monat/Tag/Jahr raus. Habe es eben auf dem Desktop versucht und da kommt dasselbe raus. Was mir dabei auffiel war, dass die Daten sich zu ändern scheinen. Wenn der Tag über den 12. hinausgeht wird das Datum Tag/Monat/Jahr angezeigt, wenn nicht Monat/Tag/Jahr. Damit funktioniert die Durchschnittsformel dann anscheinend nicht mehr. Anbei ein Bildschirmdruck mit dem was ich meine.

 

Hallo,

was ich nicht überprüft hatte, war, ob die CSV-Spaltentypen richtig erkannt und widergegeben werden, da du diesbezüglich keine Probleme mitgeteilt hattest.
Du hattest folgende Einstellungen:

Code:

      .UsedRange.Columns(1).TextToColumns Destination:=.Cells(1), DataType:=xlDelimited, _
            TextQualifier:=xlDoubleQuote, ConsecutiveDelimiter:=False, Tab:=False, _
            Semicolon:=False, Comma:=True, Space:=False, Other:=False, _
            FieldInfo:=Array(Array(3, 4), Array(15,4)), TrailingMinusNumbers:=True

Korrekt kann aber nur Folgendes sein, denn nur die 1. Spalte enthält Datumsangaben und zwar im Format "JJJJ-MM-TT". Warum du eine 3. Spalte und eine 15. Spalte ebenfalls im DMY-Quellformat angeführt hast, ist mir sowieso schleierhaft.

Code:

      .UsedRange.Columns(1).TextToColumns Destination:=.Cells(1), DataType:=xlDelimited, _
            TextQualifier:=xlDoubleQuote, ConsecutiveDelimiter:=False, Tab:=False, _
            Semicolon:=False, Comma:=True, Space:=False, Other:=False, _
            FieldInfo:=Array(Array(1, 5)), TrailingMinusNumbers:=True

Nachfolgend die Codes für die 2.Zahl in Array(1,5) - also statt der Fünf:

 

Morgen Anton,

tut mir leid, das war mir nicht klar, kam vom Original. Vielen Dank für den Änderungsvorschlag. Es funktioniert.
Kann man was wegen des Textes machen? Ich werde die naechsten Tage beobachten, ob sich der Text wieder aendert und
schauen, ob ich die Formel aendern kann.
Gibt es ein Buch zu obigem zu lernen? Ich habe was von Rheinwerk, aber keine Ahnung ob das fuer sowas wie oben gut genug ist.

 

Hallo,

was meinst du mit dieser Frage?

Falls du mit dieser Frage den Aufbau und die Auswertung des folgenden URLs meinst:
'UrlFile = "https://www.ecb.europa.eu/stats/eurofxref/eurofxref-hist.zip?2baf28632f50dcbc1dc5a7c2328464fd"
das habe ich dir doch ins Makro eingebaut, dass der Teil nach dem Fragezeichen übergangen wird und habe dir das extra im Punkt 2) erläutert, dass dieser Makroabschnitt dafür zuständig ist.

 

Entschuldige, dann habe ich es falsch verstanden. Ich dachte bzw. habe zwar verstanden, dass Du die URL getestet und den Code modifiziert hast, aber nicht, dass das auch dazu geführt hat, dass die Endung der URL quasi übergangen wird.
Das ist spitze, Vielen Dank nochmal.

 

Habe eben mal reingeschaut bei der ECB. Der neue Link ist https://www.ecb.europa.eu/stats/eurofxref/eurofxref-hist.zip?04458a0f52a0479a1099cd2e746442b5 also schon anders. Viel mir nicht auf. Wahnsinn.