Wechselkurse aus Internet laden

Sub Devisenkurse_laden()
Dim kursdatum As String
Dim bLoaded As Boolean
Dim IEApp As Object
'*********************************************************************************************** _
_
_
_
_
_
_
'* Dieses Makro lädt Devisenkurse für das eingegebene tagesdatum aus dem Internet.
'* Devisenkursseite: bankenverband.de/service/waehrungsrechner/
'* Entworfen am 25.01.18 von Peter Zerbe
'*********************************************************************************************** _
_
_
_
_
_
_
If Mid(ActiveWorkbook.Name, 1, 12) = "Kurstabelle_" Then GoTo KurstabelleIstOffen 'Prüfung ob    _
_
_
_
_
_
_
Kursdatei bereits offen
'*** auswählen und öffnen der Kursdatei und Prüfung ob die richtige Struktur vorhanden ist
With Application.FileDialog(msoFileDialogFilePicker)
.Title = "Bitte Kursdatei des betreffenden Landes auswählen"
.InitialFileName = "\\su-db\import$\100_Projektordner\330_Aktualisierung Wechselkurse" ' _
Pfad für Wechselkursdateien wird vorgegeben
If .Show = -1 Then
For Each Ordnerpfad In .SelectedItems
KursDatei = Ordnerpfad
Next Ordnerpfad
End If
End With
If KursDatei = False Then Exit Sub
Workbooks.Open (KursDatei) ' öffnen der Datei
KurstabelleIstOffen:
Sheets(1).Select ' Vorsichtshalber Aktivierung des ersten Sheets
' Strukturprüfung
If Not Range("B5").Value = "Monat" Then
MsgBox ("Die Datei hat nicht die nötige Struktur! " & vbNewLine & vbNewLine & "In der Zelle  _
_
_
_
_
_
_
B5 sollte 'Monat' stehen." & vbNewLine & vbNewLine & "Bitte bringen Sie die Datei in die nötige  _
_
_
_
_
_
Struktur und starten das Makro erneut.")
Exit Sub
End If
If Not Range("D5").Value = "Interbankenkurs" Then
MsgBox ("Die Datei hat nicht die nötige Struktur! " & vbNewLine & vbNewLine & "In der Zelle  _
_
_
_
_
_
_
D5 sollte 'Interbankenkurs' stehen." & vbNewLine & vbNewLine & "Bitte bringen Sie die Datei in   _
_
_
_
_
_
die nötige Struktur und starten das Makro erneut.")
Exit Sub
End If
If Not Range("C5").Value = "1 EUR" Then
MsgBox ("Die Datei hat nicht die nötige Struktur! " & vbNewLine & vbNewLine & "In der Zelle  _
_
_
_
_
_
_
C5 sollte '1 EUR' stehen." & vbNewLine & vbNewLine & "Bitte bringen Sie die Datei in die nötige  _
_
_
_
_
_
Struktur und starten das Makro erneut.")
Exit Sub
End If
'****** ENDE auswählen und öffnen der Kursdatei
' Ermittlung des ersten fehlenden Kurses
x = 0
Do Until Range("D" & 6 + x).HasFormula
x = x + 1
Loop
If Range("C" & 6 + x).Value  1 Then 'es wird geprüft ob die Wechselmenge (idR. 1) eingebene    _
_
_
_
_
_
_
wurde, ansonsten wird sie nachgetragen
Range("C" & 6 + x).Select
a = MsgBox("Die Wechselmenge in der makierten Zelle fehlt und wird mit dem Wert 1  _
nachgetragen wenn Sie auf OK drücken.", vbOKCancel)
If a = vbCancel Then Exit Sub
ActiveCell.Value = 1
End If
If Range("B" & 6 + x).Value = "" Then ' wenn der Kursmonat fehlt wird das Makro abgebrochen
Range("B" & 6 + x).Select
a = MsgBox("Der KursMonat in der makierten Zelle fehlt. Bitte tragen Sie ihn nach und  _
starten das Makro neu.", vbOKCancel)
Exit Sub
End If
kursdatum = Range("B" & 6 + x).Value ' Kursdatum wird ausgelsen
If (Year(kursdatum) & Month(kursdatum)) * 1 >= (Year(Date) & Month(Date)) * 1 Then 'wenn das  _
Kursdatum im aktuellen Monat oder in der Zukunft liegt, dann wird das Makro beendet
MsgBox ("Alle Kurse bis zum aktuellen Vormonat sind eingelesen, das Makro wird beendet.")
Exit Sub
End If
' Währungskürzel in 3 Buchstaben wird ermittelt
If Mid(Range("B2").Value, Len(Range("B2").Value) - 4, 1)  "(" Or Mid(Range("B2").Value, Len(   _
_
_
_
_
_
_
Range("B2").Value), 1)  ")" Then
Range("B2").Select
waehrungsKuerzel = InputBox("Das Währungskürzel konnte nicht aus der Bezeichnung in Zelle    _
_
_
_
_
_
_
B2 entonnen werden." & vbNewLine & vbNewLine & "Bitte geben sie das Kürzel in 3 Großbuchstaben   _
_
_
_
_
_
an. (z.B. KZT)")
Else
waehrungsKuerzel = Mid(Range("B2").Value, Len(Range("B2").Value) - 3, 3)
End If
Range("D" & 6 + x).Select
Set IEApp = CreateObject("InternetExplorer.Application") ' MS IE wird geöfnet
IEApp.Visible = True
IEApp.Navigate "https://bankenverband.de/service/waehrungsrechner/" 'die Kursseite wird geö _
ffnet
Do: Loop Until IEApp.Busy = False
Do: Loop Until IEApp.Busy = False 'vorsichtshalber wird 2 x gewatet ob Seite vollständig  _
geladen
'*** das Kursformular auf der Website wird mit Daten gefüllt und der Kurs geladen
With IEApp.Document
Do: Loop Until .ReadyState = "complete"
.getElementbyid("amount").Value = 1  'Betrag
.getElementbyid("base").Value = "EUR" ' Basiswährung
.getElementbyid("quote").Value = waehrungsKuerzel ' Zielwährung
.getElementbyid("date").Value = kursdatum ' Datum
.getElementbyid("decimal_points").Value = "5" ' Dezimalstellen
Do: Loop Until IEApp.Busy = False
.getElementbyid("calculateBtn").Click
.getElementbyid("calculateBtn").Click
End With
Do: Loop Until IEApp.Busy = False
Do: Loop Until IEApp.Busy = False 'vorsichtshalber wird 2 x gewatet ob Seite vollständig  _
geladen
'****** ENDE das Kursformular auf der Website wird mit Daten gefüllt und der Kurs geladen
'*** Übernahme der Kurse in die Exceldatei
'****** ENDE Übernahme der Kurse in die Exceldatei
Set IEApp = Nothing
End Sub