AW: Tabelle aus dem Web
22.09.2018 01:56:30
Zwenn
Hallo Fred,
da die Sache mit den Besorgungen aus dem Baumarkt mit dem Wochenende kollidiert, ziehe ich Deine Tabelle mal vor ;-)
Ohne große Erklärungen ... Den folgenden Code einfach in ein Modul kopieren. Die Begegnungen werden inklusive Kopfzeile in die Tabelle geschrieben, aus der Du das Makro startetst. Die Mannschaften und das Endergebnis habe ich jeweils auf 2 Spalten aufgeteilt. Weiß ja nicht, was Du mit den Werten anfangen willst. Das Datum in der ersten Spalte ist keins. Kann man aber bei Bedarf vom jetzigen englischen Format in ein deutsches umwandeln. Hatte ich jetzt nur keine Lust mehr zu. Es werden auch die Begegnungen der Zukunft ausgelesen, für die noch keine Ergebnisse vorliegen.
Option Explicit
Sub FussballErgebnisseHolen()
Dim browser As Object
Dim url As String
Dim knotenStamm As Object
Dim knotenAst As Object
Dim knotenZweig As Object
Dim knotenBlatt As Object
Dim zeile As Long
Dim spalte As Byte
Dim index As Byte
Dim splitArray() As String
'Variablen initialisieren
zeile = 2
spalte = 1
url = "https://www.soccerstats.com/results.asp?league=germany3"
'Kopfzeile schreiben
Cells(1, 1).Value = "Datum"
Cells(1, 2).Value = "Uhrzeit"
Cells(1, 3).Value = "Heimmannschaft"
Cells(1, 4).Value = "Gastmannschaft"
Cells(1, 5).Value = "Heim"
Cells(1, 6).Value = "Gast"
Cells(1, 7).Value = "Halbzeit"
Range("A1:G1").Font.Bold = True
Range("A1:G1").HorizontalAlignment = xlCenter
Columns("B:B").HorizontalAlignment = xlCenter
Columns("E:G").HorizontalAlignment = xlCenter
ActiveWindow.SplitColumn = 0
ActiveWindow.SplitRow = 1
ActiveWindow.FreezePanes = True
'Internet Explorer initialisieren, Sichtbarkeit festlegen,
'Seite aufrufen und warten, bis sie ganz geladen wurde
Set browser = CreateObject("internetexplorer.application")
browser.Visible = False
browser.navigate url
Do Until browser.readyState = 4: DoEvents: Loop
'Quelltext aus dem Body des richtigen iFrames
'holen, in dem die Ergebnisse aufgelistet sind
Set knotenStamm = browser.document.getElementByID("pmatch") _
.contentDocument.getElementsByTagName("body")(0)
If Not knotenStamm Is Nothing Then
'Relevante Tabellenzeilen einsammeln
Set knotenAst = knotenStamm.getElementsByClassName("odd")
If Not knotenAst Is Nothing Then
For Each knotenZweig In knotenAst
'Tabellenzellen der aktuellen Begegnung einsammeln
Set knotenBlatt = knotenZweig.getElementsByTagName("td")
If Not knotenBlatt Is Nothing Then
'Zellen einer Begegnung in die Excel Tabelle schreiben
'Dafür jeden Index durchgehen, weil Begegnungen, die
'noch nicht stattgefunden haben weniger Zellen haben
For index = 0 To Len(knotenBlatt)
'Datum (hier nicht auf Deutsch umgearbeitet und
'deshalb kein echtes Excel-Datum)
If index = 0 Then
Cells(zeile, spalte).Value = knotenBlatt(index).innertext
End If
'Uhrzeit
If index = 1 Then
Cells(zeile, spalte).Value = knotenBlatt(index).innertext
'1 h abziehen. Keine Ahnung warum die Uhrzeit um 1 h mehr
'ausgelesen wird. Vielleicht weil es eine britische Seite
'ist und Excel sich für schlau hält. So werden die Zeiten
'jedenfalls angezeigt, wie in der Tabelle
Cells(zeile, spalte).Value = Cells(zeile, spalte).Value _
- 4.16666666666667E-02
End If
'Heim- und Gast-Mannschaft
If index = 2 Then
'Mannschaften separieren
splitArray = Split(knotenBlatt(index).innertext, "-")
Cells(zeile, spalte).Value = Trim(splitArray(0))
spalte = spalte + 1
Cells(zeile, spalte).Value = Trim(splitArray(1))
End If
If index = 3 Then
'Ergebnis separieren
splitArray = Split(knotenBlatt(index).innertext, "-")
If IsNumeric(Trim(splitArray(0))) Then
Cells(zeile, spalte).Value = Trim(splitArray(0)) * 1
End If
spalte = spalte + 1
If UBound(splitArray) > 0 Then
If IsNumeric(Trim(splitArray(1))) Then
Cells(zeile, spalte).Value = Trim(splitArray(1)) * 1
End If
End If
End If
'Halbzeitstand
On Error Resume Next
If index = 4 Then
Cells(zeile, spalte).Value = knotenBlatt(index).innertext
End If
On Error GoTo 0
spalte = spalte + 1
Next index
spalte = 1
zeile = zeile + 1
End If
Next knotenZweig
End If
End If
'Spalten auf die richtige Breite setzen
Columns("A:G").EntireColumn.AutoFit
'Aufräumen
browser.Quit
Set browser = Nothing
Set knotenStamm = Nothing
Set knotenAst = Nothing
Set knotenZweig = Nothing
Set knotenBlatt = Nothing
End Sub
Viele Grüße,
Zwenn