AW: vba, mehrere Seiten laden
02.05.2023 18:52:43
Yal
Hallo Fred,
jetzt bin ich derjenige, der sich zeit lässt.
Deine Sub ist sauber. Beseitige nur die Variable, die nicht mehr gebraucht werden.
Variable, deren Zustand sich nicht ändern, sind Konstanten.
InStr ist immer null (wird als False interpretiert) oder positiv (wird als True interpretiert), da kann man kürzen.
Wenn der Trenner ein Leerzeichen ist, muss man nur dafür sorgen, dass diese am Ende beseitig wird und man muss nicht die Fälle "erste Befüllung", "folge Befüllung" verwalten.
Eine Variable "Cell" zu nennen ist unglücklich: zu nah am VBA "Cells": es erschwert das Lesen.
Sieht so aus (ich habe den Token rausgemacht):
Sub Fetch_GoalMins()
Dim StartTime As Long
Dim StartRow As Long, LastRow As Long
Dim Z As Range
Dim homeTeam As String, homeMins As String
Dim awayTeam As String, awayMins As String
Const matchURL = "https://api.b365api.com/v1/event/view?token="
Const token_Str = "xxx"
StartRow = CLng(InputBox("Trage die Startzeile ein (11)"))
LastRow = CLng(InputBox("Trage die letzte auszufüllende Zeile ein"))
StartTime = Timer
Set xmlHttp = CreateObject("MSXML2.ServerXMLHTTP.6.0")
Application.ScreenUpdating = False
For Each Z In Range(Cells(StartRow, 1), Cells(LastRow, 1))
homeMins = ""
awayMins = ""
If Cells(Z.Row, 59).Value = "" And Z.Value > "" And Cells(Z.Row, 14).Value > "0-0" Then
homeTeam = Cells(Z.Row, 12).Value
awayTeam = Cells(Z.Row, 13).Value
Restart:
xmlHttp.Open "GET", matchURL & token_Str & "&event_id=" & Z.Value, False
xmlHttp.setRequestHeader "User-Agent", "Mozilla/5.0 (Windows NT 10.0; Win64; x64) AppleWebKit/537.36 (KHTML, like Gecko) Chrome/75.0.3770.100 Safari/537.36"
On Error GoTo SendError
xmlHttp.send
On Error GoTo 0
Set JSON = JsonConverter.ParseJson(xmlHttp.responseText)
For Each gameEvent In JSON("results")(1)("events")
If InStr(1, gameEvent("text"), " Goal - ") And InStr(1, gameEvent("text"), "'") Then
If InStr(1, gameEvent("text"), homeTeam) Then
homeMins = homeMins & " " & Split(gameEvent("text"), "'")(0)
ElseIf InStr(1, gameEvent("text"), awayTeam) Then
awayMins = awayMins & " " & Split(gameEvent("text"), "'")(0)
End If
End If
Next gameEvent
Cells(Z.Row, 59).Value = Trim(homeMins) 'ohne führenden Leerzeichen
Cells(Z.Row, 60).Value = Trim(awayMins)
Sleep ("200")
' If Z.Row > 11 Then Exit For
End If
Next Z
Debug.Print Timer - StartTime
MsgBox ("Finished")
'IE.Quit
Application.ScreenUpdating = True
Exit Sub
SendError:
Resume Restart
End Sub
VG
Yal