Microsoft Excel

Herbers Excel/VBA-Archiv

Informationen und Beispiele zum Thema MsgBox
BildScreenshot zu MsgBox MsgBox-Seite mit Beispielarbeitsmappe aufrufen

@michax Kursabfrage

Betrifft: @michax Kursabfrage von: Zwenn
Geschrieben am: 26.10.2020 23:47:18

Hallo michax,

ich hoffe Du findest diesen Thread, da Deiner im Archiv versunken ist:
https://www.herber.de/forum/cgi-bin/callthread.pl?index=1788456

Dein Trick mit dem setzen des Datums über das hidden input field funktioniert nicht mehr. Man muss jetzt wirklich einigen Aufwand betreiben. Deiner Tabelle habe ich entnommen, dass Du immer Werte für das Datum in C1 holst. Das funktioniert jetzt wieder. Ich habe das Ganze neu geschrieben, weil es auch andere Dinge gab, wie die Verhinderung einer Endlosschleife, die ich nicht verstanden habe.

Ich habe alles ausführlich kommentiert. Du solltest also einigermaßen nachvollziehen können, was da passiert. Sollte das Wechseln der Kalenderblätter "stecken bleiben" (ggf. den IE zum Test bei Problemen sichtbar schalten), musst Du evtl. die Zeit von Sleep() nach oben anpassen. Auf meinem Rechner läuft das gut mit 100 mS zwischen dem Rückblätern durch die Monate.

Ich liste hier einmal den VBA Code, damit andere ggf. nicht zwingend die Exceldatei mit Makros runterladen müssen (mag nicht jeder). Ich mache mir dafür allerdings nicht die Mühe, die durch die Fornesoftware verursachten Zeilenumbrüche im Quellcode zu vermeiden. In den Makros habe ich selbst keinen Zeilenumbruch programmiert. Es können also ggf. alle entfernt werden.

In der Tabelle, in der das Makro laufen soll, folgendes Workbook_Change Event Makro eintragen:

Private Sub Worksheet_Change(ByVal Target As Range)
  If Target = ActiveSheet.Range("C1") Then
    KreditKartenWechselKurse
  End If
End Sub
In ein allgemeines Modul folgenden Kopf eintragen:
Option Explicit
Option Private Module

#If VBA7 And Win64 Then
    Private Declare PtrSafe Sub Sleep Lib "kernel32" (ByVal dwMilliseconds As Long)
#Else
    Private Declare Sub Sleep Lib "kernel32" (ByVal dwMilliseconds As Long)
#End If
Unter den Kopf im allgemeinen Modul das eigentliche Makro kopieren:
Sub KreditKartenWechselKurse()

Const url As String = "https://online.firstdata.com/CurrencyCalculator/fremdwaehrungskurse/ _
calendar"

Dim chosenDate As Date
Dim chosenDateMonthName As String
Dim startRow As Long
Dim currentRow As Long
Dim currentCol As Long
Dim nodeInput As Object
Dim nodeDropdown As Object
Dim nodeCalMonthNav As Object
Dim nodeCalNav As Object
Dim currentCalMonth As String
Dim nodeAllDays As Object
Dim nodeOneDay As Object
Dim nodeResultPage As Object
Dim nodeResult As Object
Dim nodeRow As Object
Dim nodeCell As Object
Dim splitArray() As String

  'Variablen initialisieren
  startRow = 2
  currentCol = 3
  
  'Sicher stellen, dass das Datum für den Abruf innerhalb
  'des letzten halben Jahres seit gestern liegt
  'Ggf. wird die obere oder untere Datumsgrenze gesetzt
  If IsDate(ActiveSheet.Cells(1, 3)) Then
    'Steht in C1 ein Datum, dises als gegeben annehmen
    chosenDate = CDate(ActiveSheet.Cells(1, 3))
    'Prüfen, ob es innerhalb der erlaubten Datumsgrenzen liegt
    Select Case chosenDate
      Case Is >= Date: chosenDate = Date - 1
      Case Is < DateAdd("m", -6, Date): chosenDate = DateAdd("m", -6, Date)
    End Select
    'Events abschalten, weil wir in C1 schreiben und dies
    'das workbook_change Event erneut auslösen würde
    Application.EnableEvents = False
    'Gewähltes Datum in C3 schreiben
    ActiveSheet.Cells(1, 3) = chosenDate
    'Events wieder einschalten
    Application.EnableEvents = True
  Else
    'Es steht kein Datum in C1
    MsgBox "Bitte ein Datum in Zelle C1 eingeben"
    'Makro beenden
    Exit Sub
  End If
  
  'Alle Währungen durchgehen
  For currentRow = startRow To ActiveSheet.Cells(Rows.Count, 2).End(xlUp).Row
    'Internet Explorer initialisieren, Sichtbarkeit festlegen,
    'URL aufrufen und warten bis Seite vollständig geladen wurde
    With CreateObject("internetexplorer.application")
      .Visible = False
      .Navigate url
      Do Until .ReadyState = 4: DoEvents: Loop

      'Pauschal beide Haken in Checkboxen für Kreditkarten setzen
      'Das sind die input-Tags mit den Indizes 2 und 3 in der NodeCollection
      Set nodeInput = .Document.getElementsByTagName("input")
      nodeInput(2).Checked = True
      nodeInput(3).Checked = True

      'Währung wählen
      Set nodeDropdown = .Document.getElementByID("Waehrung")
      nodeDropdown.Value = ActiveSheet.Cells(currentRow, 2).Value
      
      'Gewähltes Datum im Kalender auf der Webseite anklicken
      'Das ist etwas tricky, weil man dazu ggf. durch die
      'letzten 6 Monate navigieren muss
      '
      'Dazu benötigen wir zunächst den Monatsnamen als Wort,
      'um den aktuell angezeigten Monat degegen abzugleichen
      chosenDateMonthName = Format(chosenDate, "mmmm")
      '
      'Das angezeigte Datum im Kalender ist heute
      'Also ggf. solange rückwärts durch die Monate
      'klicken, bis der gesuchte Monat erreicht wurde
      'Durch den anfänglichen Abgleich des Datums
      'in C1 gegen das letzte halbe Jahr, liegt der
      'gesuchte Monat auf jeden Fall innerhalb der
      'letzten sechs Monate
      Do
        'Rückwärts Monats Navigation des Kalenders zur Verfügung stellen
        'Muss nach jedem Monatsaufruf gemacht werden, weil das Element
        'sich ändert und damit für die Nutzung verfällt
        Set nodeCalMonthNav = .Document.getElementsByClassName("calnavleft")(0)
        '
        'In der Gesamtnavigation steht der Monat
        Set nodeCalNav = .Document.getElementsByClassName("calheader")(0)
        'Den Monatsnamen aus dem Text der Navigation extrahieren
        'Wir benutzen Split mit dem Standarddelimiter Freizeichen
        'Dann ist der Monat das 5. Array Element
        splitArray = Split(Trim(nodeCalNav.innertext))
        
        'Klicken, wenn der Monat im Kalender ungleich unserem gesuchten Monat ist
        If splitArray(4) <> chosenDateMonthName Then
          'Bei Ungleichheit einen Monat zurück navigieren
          nodeCalMonthNav.Click
          '100 mS warten, um den Kalender neu aufzubauen
          'Nach oben anpassen, wenn Zielmonat nicht erreicht wird
          Sleep (100)
        End If
      Loop Until splitArray(4) = chosenDateMonthName
      '
      'Alle anklickbaren Tage des Kalenderblattes sind a-Tags
      Set nodeAllDays = .Document.getElementsByClassName("calbody")(0).getElementsByTagName("a") _

      '
      'Alle Tage durchgehen und den richtigen anklicken
      For Each nodeOneDay In nodeAllDays
        'Der Vergleich muss auf den gleichen Datentyp stattfinden
        'Wir wandeln deshalb die Zahl des gewählten Datums-Tages
        'in einen String um
        If nodeOneDay.innertext = CStr(Day(chosenDate)) Then
          'Klicken wenn gefunden
          nodeOneDay.Click
          'Schleife verlassen
          Exit For
        End If
      Next nodeOneDay
      
      'Jetzt kann der Submit-Button geklickt werden
      .Document.querySelector("input[value='submit']").Click
      
      'Warten, bis die Ergebnisseite geladen wurde
      Do
        On Error Resume Next
        Set nodeResultPage = .Document.getElementsByClassName("resultsTable")(0)
        On Error GoTo 0
      Loop Until Not nodeResultPage Is Nothing
      
      'Ergebniszeile in der Excel-Tabelle ausgeben
      'aus der das Makro gestartet wurde
      Set nodeResult = .Document.getElementsByClassName("even")(0)
      Set nodeRow = nodeResult.getElementsByTagName("td")
      For Each nodeCell In nodeRow
        Cells(currentRow, currentCol) = Trim(nodeCell.innertext)
        currentCol = currentCol + 1
      Next nodeCell
      currentCol = 3

      'IE beenden
      .Quit
    End With
  Next currentRow
End Sub
Hier ist das Ganze bereits fertig zusammengebastelt und mit funktionierenden Tabellen dazu:
https://www.herber.de/bbs/user/141115.xlsm

Ich hoffe das läuft bei Dir und die ändern nicht so bald wieder etwas ;-)

Viele Grüße,

Zwenn

Betrifft: AW: @michax Kursabfrage
von: michax
Geschrieben am: 30.10.2020 13:18:08

Hi Zwenn (meine Rettung),

ja habe es gefunden und (ich ziehe abermals meinen Hut vor Dir) es läuft auch bei mir. Toll!!! und wirklich ein riesiges Dankeschön an Dich - das hätte ich selbst nicht hinbekommen. Ich schau gleich mal den Code durch und lerne :-)

vG
michax

Beiträge aus dem Excel-Forum zum Thema "@michax Kursabfrage"