AW: ...und hier noch ein zweiter Lösungsweg
31.10.2016 17:05:17
Martin
Hallo Stefan,
okay, hier die Lösung ohne ständigem Neustart des InternetExplorers:
Option Explicit
Private IEApp As Object
Sub ResultLoop()
'In TimeSerial(hh:mm:ss) festlegen bis wann die Schleife laufen soll
If Time() > TimeSerial(22, 30, 10) Then
If Not IEApp Is Nothing Then
IEApp.Quit
Set IEApp = Nothing
Exit Sub
End If
End If
Application.OnTime Now + TimeValue("00:00:30"), "GetRaceResults"
End Sub
Sub GetRaceResults()
Dim htmlTable As Object, j As Long
If IEApp Is Nothing Then
Set IEApp = CreateObject("InternetExplorer.Application")
IEApp.Visible = False
IEApp.navigate "https://livetiming.raceresults.nu/autodromodoalgarve#screen-results"
Else
IEApp.Refresh
End If
Do: Loop Until IEApp.Busy = False
Do: Loop Until IEApp.Busy = False
Do: Loop Until IEApp.document.readyState = "complete"
Application.Calculation = xlCalculationManual
Application.ScreenUpdating = False
Cells.Delete
For Each htmlTable In IEApp.document.all.tags("TABLE")
If htmlTable.Rows(0).Cells(0).innerText = "POS" Then
For j = 0 To htmlTable.Rows.Length - 1
With htmlTable.Rows(j)
Cells(j + 1, 1) = .Cells(0).innerText
Cells(j + 1, 2) = .Cells(3).innerText
Cells(j + 1, 3) = .Cells(4).innerText
Cells(j + 1, 4) = .Cells(6).innerText
Cells(j + 1, 5) = .Cells(7).innerText
Cells(j + 1, 6) = .Cells(9).innerText
Cells(j + 1, 7) = .Cells(8).innerText
Cells(j + 1, 8) = .Cells(10).innerText
End With
Next j
Exit For
End If
Next
Columns("A:H").EntireColumn.AutoFit
Application.Calculation = xlCalculationAutomatic
Application.ScreenUpdating = True
Call ResultLoop
End Sub
Da ich kein Mac-User bin, kann ich dir leider fast nicht weiterhelfen. Aber einen möglichen Lösungsansatz habe ich dennoch: https://de.wikipedia.org/wiki/Selenium
Selenium läuft wohl auch unter Mac, ich habe damit unter Windows bereits Firefox angesteuert.
Ich habe keine Ahnung welche "grüne Punkte oder Pfeile" du meinst. Wenn diese nicht als Textinhalt nach Excel übertragen werden, handelt es sich wahrscheinlich um irgendwelche Objekte (z.B. Grafiken) und müssten explizit in den HTML-Zellen abgefragt und - falls vorhanden - nach Excel übertragen werden. Das ist mir jetzt aber zu umständlich zu programmieren ;-)
Ich hatte noch eine andere Variante ohne InternetExplorer versucht, die ich noch besser finde und die auch superschnell läuft. Leider ist diese Variante auf deine Seite wegen des JavaScriptes nicht anwendbar. Da ich die Programmierarbeit nun - wenn auch umsonst - gemacht habe, poste ich den Code trotzdem mal:
Sub Variante2()
Dim HTTP As Object, strURL As String
Dim odoc As Object, htmlTable As Object, j As Integer
Set HTTP = CreateObject("MSXML2.ServerXMLHTTP")
Set odoc = CreateObject("htmlfile")
strURL = "https://livetiming.raceresults.nu/autodromodoalgarve#screen-results"
HTTP.Open "GET", strURL, False
HTTP.send
odoc.Open
odoc.write HTTP.responseText
odoc.Close
Application.Calculation = xlCalculationManual
Application.ScreenUpdating = False
Cells.Delete
For Each htmlTable In odoc.all.tags("TABLE")
If htmlTable.Rows(0).Cells(0).innerText = "POS" Then
For j = 0 To htmlTable.Rows.Length - 1
With htmlTable.Rows(j)
Cells(j + 1, 1) = .Cells(0).innerText
Cells(j + 1, 2) = .Cells(1).innerText
Cells(j + 1, 3) = .Cells(2).innerText
Cells(j + 1, 4) = .Cells(3).innerText
Cells(j + 1, 5) = .Cells(4).innerText
Cells(j + 1, 6) = .Cells(5).innerText
Cells(j + 1, 7) = .Cells(8).innerText
Cells(j + 1, 8) = .Cells(10).innerText
End With
Next j
Exit For
End If
Next
Application.Calculation = xlCalculationAutomatic
Application.ScreenUpdating = True
End Sub
Viele Grüße
Martin