un po di tempo fa il mitico Anthony47 scrisse un macro per importare il calendario di calcio da betexplorer che funziona perfettamente appunto sul quel sito.
utilizzando la stessa su questo sito
link.
https://www.scorespro.com/soccer/german ... a/results/
importa soltanto la prima pagina
in questo caso le pagine sono sei.
sempre se è possibile vorrei importare tutto il calendario
la macro utilizzata è questa
- Codice: Seleziona tutto
Sub importa_calendario()
Sheets("Class1").Select '<<< Il foglio su cui si fara' l'importazione
Range("a:k").ClearContents 'NB: Il fofglio SARA' AZZERATO senza preavviso
Range("a:k").NumberFormat = "@" 'Colonne in formato Testo
Sheets("Class1").Select
Call GetTabbbSubOptAll1(Range("p1").Value) ' "Chiama" la GetTabbbSub
Range("a:k").WrapText = False
End Sub
Sub GetTabbbSubOptAll1(ByVal myURL As String)
'Va Chiamata passandogli l'URL da leggere
'Variante 2 per betexplorer.com
Dim IE As Object, I As Long
Set IE = CreateObject("InternetExplorer.Application")
'
Debug.Print ">>>", myURL
With IE
.navigate myURL
.Visible = False
'Stop 'Vedi TESTO
End With
Call IEReady1(IE, 1)
'
'Cerca i Select 1° e 2° Class=wrap-header__list__item semilong:
Dim myItm As Object, myColl As Object, mmColl As Object, ccColl As Object
For I = 0 To 1
On Error Resume Next
Set myColl = IE.document.getElementsByClassName("wrap-header__list__item semilong")
Set myItm = myColl(I)
Set mmColl = myItm.getElementsByTagName("option")
Set ccColl = myItm.getElementsByTagName("select")
On Error GoTo 0
If myColl.Length = 2 Then
Debug.Print "d", mmColl.Length
ccColl(0).selectedIndex = mmColl.Length - 1
Debug.Print "e", ccColl(0).selectedIndex
ccColl(0).FireEvent "onchange"
Call IEReady1(IE, 3)
End If
Next I
'Scrive le tabelle SUL FOGLIO ATTIVO
Set myColl = IE.document.getElementsByTagName("TABLE")
For Each myItm In myColl
'''Set myItm = myColl(1) '0=tab #1; 1 = tab #2, etc
Cells(I + 1, 1) = "Table# " & ti + 1
ti = ti + 1: I = I + 1
For Each trtr In myItm.Rows
For Each tDtD In trtr.Cells
If tDtD.className = "form col_form" Then
Set my2Coll = tDtD.getElementsByTagName("span")
If my2Coll.Length > 0 Then
myout = " "
'Gestion tabella FORM:
For Each pippo In my2Coll
aaaa = pippo.className
If InStr(1, aaaa, "form-s", vbTextCompare) > 0 Then myout = "?-"
If InStr(1, aaaa, "form-l", vbTextCompare) > 0 Then myout = myout & "L-"
If InStr(1, aaaa, "form-w", vbTextCompare) > 0 Then myout = myout & "W-"
If InStr(1, aaaa, "form-d", vbTextCompare) > 0 Then myout = myout & "D-"
Next pippo
myout = Trim(Left(myout, Len(myout) - 1))
Cells(I + 1, J + 1) = myout
J = J + 1
End If
Else
Cells(I + 1, J + 1) = tDtD.innerText
'Legge hyperlink:
If InStr(1, tDtD.innerHTML, "href", vbTextCompare) > 0 Then
DoEvents: DoEvents
On Error Resume Next
ActiveSheet.Hyperlinks.Add anchor:=Cells(I + 1, J + 1), _
Address:=tDtD.getElementsByTagName("a")(0).href
On Error GoTo 0
End If
J = J + 1
End If
Next tDtD
'Allinea al centro se e' una Intestazione:
If trtr.className = "js-tournament" Then
Cells(I + 1, 1).HorizontalAlignment = xlCenter
End If
I = I + 1: J = 0
DoEvents
Next trtr
I = I + 1
Next myItm
'
'Chiusura IE
IE.Quit
Set IE = Nothing
End Sub
Sub IEReady1(ByRef myIE As Object, myStab As Single)
Dim myLStart As Single
With myIE
Do While .Busy: DoEvents: Loop 'Attesa not busy
Do While .readyState <> 4: DoEvents: Loop 'Attesa documento
End With
myLStart = Timer 'attesa addizionale
Do
DoEvents
If Timer > (myLStart + myStab) Or Timer < myLStart Then Exit Do
Loop
End Sub
grazie