importare da web

[rombotuono]

buongiorno
excel
avrei un quesito da porvi in merito alla macro da voi suggerita.
come posso modificarla per poter importare le varie tabelle con link.
vorrei importare per esempio questa tabella con i collegamenti.
questo è il link
https://www.betexplorer.com/soccer/alge ... n&dcheck=0

macro da voi suggerita
in parte funziona

Sub Call1()
Sheets("Foglio3").Select '<<< Il foglio su cui si fara' l'importazione
Range("A:X").ClearContents 'NB: Il fofglio SARA' AZZERATO senza preavviso
Range("A:X").NumberFormat = "@" 'Colonne in formato Testo
Call GetTabbbSub(Range("Z1").Value) ' "Chiama" la GetTabbbSub
Range("A:X").WrapText = False
End Sub

Sub GetTabbbSub(ByVal myURL As String)
'Va Chiamata passandogli l'URL da leggere
Set IE = CreateObject("InternetExplorer.Application")
'
With IE
.navigate myURL
.Visible = True
'Stop 'Vedi TESTO
Do While .Busy: DoEvents: Loop 'Attesa not busy
Do While .readyState <> 4: DoEvents: Loop 'Attesa documento
End With
'
myStart = Timer 'attesa addizionale
Do
DoEvents
If Timer > myStart + 1 Or Timer < myStart Then Exit Do
Loop
'Scrive le tabelle SUL FOGLIO ATTIVO
Set myColl = IE.document.getElementsByTagName("TABLE")
For Each myItm In myColl
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
Cells(I + 1, j + 1) = tDtD.innerText
Cells(I + 1, j + 1).HorizontalAlignment = xlLeft
'Legge hyperlink:
If InStr(1, tDtD.innerHTML, "href", vbTextCompare) > 0 Then
DoEvents: DoEvents
ActiveSheet.Hyperlinks.Add anchor:=Cells(I + 1, j + 1), _
Address:=tDtD.getElementsByTagName("a")(0).href
End If
If j > 0 And Len(Cells(I + 1, j + 1)) > 2 Then cz = 1
j = j + 1
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

[Anthony47]

Ciao rombotuono, benvenuto nel forum

Se vuoi importare i dati e i relativi hyperlink, allora prova usando la variante di Sub GetTabbbSub suggerita ad altro utente in questo messaggio: viewtopic.php?p=645074#p645048

Ciao

[rombotuono]

grazie per la risposta
ho già provato la macro carica questa tabella con il collegamento solo nella colonna form
vorrei il collegamento anche nella colonna b dove si trovano i team.
[

vorrei caricare questa

grazie

[Anthony47]

Quale e' l'URL della pagina che vorresti importare? O come ci si arriva?

Ciao

[rombotuono]

Anthony47
l'url e questo
https://www.betexplorer.com/soccer/alge ... n&dcheck=0
ciao
grazie

[rombotuono]

oppure questo
https://www.betexplorer.com/soccer/algeria/ligue-1/

[Anthony47]

Ecco come stamattina la pagina indicata nell'ultimo tuo link appare nel browser:


Esaminando ad esempio la voce circolettata in blu si vede che ad essa non e' associato nessun hyperlink che attivi una navigazione, ma un javascript che viene eseguito dal browser sull'evento "onclick":


Non e' possibile importare lo script su Excel (per quel che ne so, ben intesi), quindi devi accontentarti dell'hyperlink, dove esiste.

Ne approfittiamo pero' per un paio di variazione al codice:
1) nella Sub Call1, usiamo ".Clear" invece che ".ClearContents

Codice: Seleziona tutto

Range("A:X").Clear        'NB: Il fofglio SARA' AZZERATO senza preavviso


2) Nella Sub GetTabbbSub, inseriamo On Error Resume Next / On Error GoTo 0 "attorno all'istruzione che inserisce l'hyperlink sulla celle:

Codice: Seleziona tutto

                On Error Resume Next             '++++
                    ActiveSheet.Hyperlinks.Add anchor:=Cells(I + 1, j + 1), _
                       Address:=tDtD.getElementsByTagName("a")(0).href
                    On Error GoTo 0              '++++


(vedi righe marcate ++++)

Ti segnalo anche quest'altra variante che importa anche i dati delle colonne FORM:

Codice: Seleziona tutto

Sub GetTabbbSub(ByVal myURL As String)
'Va Chiamata passandogli l'URL da leggere
'Variante per betexplorer.com
Set IE = CreateObject("InternetExplorer.Application")
'
With IE
    .navigate myURL
    .Visible = True
'Stop                                  'Vedi TESTO
    Do While .Busy: DoEvents: Loop    'Attesa not busy
    Do While .readyState <> 4: DoEvents: Loop 'Attesa documento
End With
'
myStart = Timer  'attesa addizionale
Do
    DoEvents
    If Timer > myStart + 1 Or Timer < myStart Then Exit Do
Loop
'Scrive le tabelle SUL FOGLIO ATTIVO
Set myColl = IE.document.getElementsByTagName("TABLE")
For Each myItm In myColl
    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 = "  "
                    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


Ciao

[rombotuono]

grazie
gentilissimo

[rombotuono]

volevo chiederti un'altra cortesia se è possibile importare questa tabella
https://i.postimg.cc/x100vKvt/Screenshot-65.png
link
https://www.betexplorer.com/soccer/alge ... /4dNPse1A/

[Anthony47]

Quale e' il problema che incontri con questa tabella?

[rombotuono]

si riesce ad importare soltanto le ultime 10
vorrei importare la tabella all results


https://i.postimg.cc/xd0RdYCC/Screenshot-67.png

[Anthony47]

Ah, non avevo notato...
In questo caso bisogna interagire con la pagina I.E. e la macro si complica leggermente.
Mi pare che possa andare questa versione:

Codice: Seleziona tutto

Sub GetTabbbSubOptAll(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 = True
'Stop                                  'Vedi TESTO
End With
Call IEReady(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 "A", mmColl.Length
        ccColl(0).selectedIndex = mmColl.Length - 1
        Debug.Print "B", ccColl(0).selectedIndex
        ccColl(0).FireEvent "onchange"
        Call IEReady(IE, 3)
    End If
Next I
'Scrive le tabelle SUL FOGLIO ATTIVO
Set myColl = IE.document.getElementsByTagName("TABLE")
For Each myItm In myColl
    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 IEReady(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


Poi nella Call1 richiamerai la Sub GetTabbbSubOptAll nel solito modo.

Ora dovresti avere una casistica sufficientemente varia per poter gestire altre variazioni sul tema.

Ciao

[rombotuono]

Grandissimo
Anthony47
funziona molto bene è quello che cercavo.
un'ultima richiesta , se volessi importare soltanto la tabella Table# 5 e poter spostare in altra zona del foglio l'importazione cosa devo cambiare.
ancora
grazie

[Anthony47]

La macro e' fatta per importare tutte le tabelle presenti nel sito; se te ne interessa solo una la puoi individuare e utilizzarne i dati, oppure copiarla dove vuoi. Nel caso la cosa e' fattibile praticamente con una macro autoregistrata, che con qualche piccolo perfezionamento diventa:

Codice: Seleziona tutto

Sub SpostaT5()
'
LookFor = "Table# 5"
'
On Error Resume Next
    Cells.Find(What:=LookFor, After:=Range("A1"), LookIn:=xlFormulas, _
        LookAt:=xlPart, SearchOrder:=xlByRows, SearchDirection:=xlNext, _
        MatchCase:=False, SearchFormat:=False).Activate
On Error GoTo 0
If ActiveCell.Value = "Table# 5" Then
    Selection.CurrentRegion.Copy Destination:=Sheets("Foglio2").Range("A1")  '<<< COPIARE DOVE?
End If
End Sub


Ciao

[rombotuono]

perfetto
tutto ok
grazie

[rombotuono]

buongiorno
Anthony47
ho testato a fondo la macro e funziona perfettamente.
l'unico problema è la tempistica, mi spiego meglio
se importo i dati da un solo campionato tutto ok il tempo di importazione è ottimo
se faccio l'importazione da più campionati parlo (200) il tempo purtroppo importando tutto quello che è presente nella pagina
diventa tremendamente lungo.
chiedo se è possibile importare soltanto quello che mi serve per esempio la tabella 1 in questo modo i tempi si ridurrebbero decisamente.
link di esempio
https://www.betexplorer.com/soccer/algeria/ligue-1/
grazie

[Anthony47]

Se vuoi importare una sola tabella, allora nel codice della Sub GetTabbbSubOptAll sostituisci la riga For Each myItm In myColl con

Codice: Seleziona tutto

Set myItm = myColl(0)         '0=tab #1; 1 = tab #2, etc

Contemporaneamente elimina la riga Next myItm

Ciao

[rombotuono]

grazie