[Macro]Importare dati da URL attivati con Javascript

[daviluc61]

Innanzitutto buongiorno a tutti e auguri per queste festività. Avrei bisogno delle vostre competenze per risolvere un problema di programmazione. Tramite la macro seguente, riesco a importare dati dal sito del myURL. Poichè nella tabella, e precisamente in colonna B vanno a finire dati che sul sito appaiono come link, come posso trasformare questa macro affinchè possa importare i dati con i link?
Infinitamente grazie

Codice: Seleziona tutto

Sub Macro1()

Application.Calculation = xlCalculationManual

myURL = "http://stats.betradar.com/s4/?clientid=5&language=it#2_1,3_17,22_1,5_41264,9_fixtures,231_full,23_1"

Set ie = CreateObject("InternetExplorer.Application")

With ie
.navigate myURL
.Visible = True
Do While .Busy: DoEvents: Loop
Do While .readyState <> 4: DoEvents: Loop
End With
'
myStart = Timer
Do
DoEvents
If Timer > myStart + 2 Or Timer < myStart Then Exit Do
Loop

I = 1
Worksheets("Foglio1").Activate
Range("A:G").Clear
Set mycoll = ie.document.getElementsByTagName("TABLE")
For Each myItm In mycoll
For Each trtr In myItm.Rows
For Each tdtd In trtr.Cells
Cells(I + 1, J + 1) = tdtd.innerText
J = J + 1
Next tdtd
I = I + 1: J = 0
Next trtr
I = I + 1
Next myItm

ie.Quit
Set ie = Nothing
Calculate

End Sub

[Anthony47]

Tramite la macro seguente, riesco a importare dati dal sito del myURL.

Questa macro la conosco...

Il sito in discussione (betradar.com) espone come hyperlink un suo javascript, quindi non c'e' un indirizzo sicuro associabile.
Ho simulato qualcosa guardando il comportamento dello script, ma quanto che questo approccio funzioni anche domani, o tra una settimana, o tra un mese nessuno te lo garantisce.
Il codice complessivo:

Codice: Seleziona tutto

Sub BetRadar()
'''Application.Calculation = xlCalculationManual
Dim IE As Object
Dim myURL As String, myHL As String
Dim mySplit, tDtD, tRtR
Dim I As Long, J As Long

myURL = "http://stats.betradar.com/s4/?clientid=5&language=it#2_1,3_17,22_1,5_41264,9_fixtures,231_full,23_1"
myHL = "http://stats.betradar.com/s4/?clientid=5&language=it#2_1,3_17,22_1,5_41264,9_match,8_#####,178_2055,7_2061"

Set IE = CreateObject("InternetExplorer.Application")

With IE
.navigate myURL
.Visible = True
Do While .Busy: DoEvents: Loop
Do While .readyState <> 4: DoEvents: Loop
End With
'
myStart = Timer
Do
DoEvents
If Timer > myStart + 2 Or Timer < myStart Then Exit Do
Loop

I = 1
Worksheets("Foglio1").Activate
Range("A:G").Clear
Set mycoll = IE.document.getElementsByTagName("TABLE")
For Each myItm In mycoll
    For Each tRtR In myItm.Rows
        For Each tDtD In tRtR.Cells
            Cells(I + 1, J + 1) = tDtD.innerText
'Per hLink>>:
                Set piPP = tDtD.getElementsByTagName("a")
                If piPP.Length > 0 Then
                mySplit = Split(piPP(0).href, ",", , vbTextCompare)
                    If UBound(mySplit) = 2 Then
                        ActiveSheet.Hyperlinks.Add Anchor:=Cells(I + 1, J + 1), Address:= _
                        Replace(myHL, "#####", Trim(mySplit(1)), , , vbTextCompare), TextToDisplay:=Cells(I + 1, J + 1).Value
                    End If
                End If
'<< End hLink
            J = J + 1
        Next tDtD
        I = I + 1: J = 0
    Next tRtR
    I = I + 1
Next myItm

IE.Quit
Set IE = Nothing
Calculate
End Sub

Prova e fai sapere...

[daviluc61]

ti ringrazio Anthony. Risolto

[daviluc61]

Anthony, una cosa volevo chiederti. Quando scarico il contenuto dei vari link, come posso scaricare anche le icone dei gol. Mi spiego meglio: quando scarico il link, mi trovo le voci dei diversi minuti in cui accadono le sostituzioni, i cartellini, i goal. Come posso scaricare solo i goal?. Grazie

[Anthony47]

Parli degli hyperlink aggiunti sul foglio o di quali link? Inoltre, puoi pubblicare il codice che usi per la loro importazione?

Ciao

[daviluc61]

Parlo degli hyperlink scaricati con la macro precedente (myHL).
myURL = "http://stats.betradar.com/s4/?clientid=5&language=it#2_1,3_17,22_1,5_41264,9_fixtures,231_full,23_1"
myHL = "http://stats.betradar.com/s4/?clientid=5&language=it#2_1,3_17,22_1,5_41264,9_match,8_#####,178_2055,7_2061"

Orbene quando scarico singolarmente questi hyperlink su un altro foglio, mi ritrovo una serie di minuti che, sul sito, sono affiancati a una icona (quella del goal, quella della sostituzione, etc) . A me interessa avere sul foglio solo i minuti che sono affiancati dalla icona del gol o, per lo meno, capire quali sono i minuti che sono affiancati dall'icona del gol.

<td class="goal icon sport-1 home first" title="Gol"><span class="goal icon sport-1 home"></span></td>)
<td class="goal icon sport-1 away" title="Gol"><span class="goal icon sport-1 away"></span></td>

Gentilissimo come sempre

[Anthony47]

Quella macro e' nata per estrarre i dati tabellari da un sito, tu vuoi fare una cosa diversa.
Comunque modificando la parte centrale puoi ottenere anche l'indicazione di quale flag sia contenuto nella cella (yellow, goal, substitution):

Codice: Seleziona tutto

I = 1
Worksheets("Foglio2").Activate
Range("A:G").Clear
Set mycoll = IE.document.getElementsByTagName("TABLE")
For Each myItm In mycoll
    For Each tRtR In myItm.Rows
        For Each tDtD In tRtR.Cells
            picon = InStr(1, tDtD.classname, " icon", vbTextCompare)
            If picon > 0 Then
                Cells(I + 1, J + 1) = Left(tDtD.classname, picon ) & tDtD.innertext
            Else
                Cells(I + 1, J + 1) = tDtD.innertext
            End If
'Per hLink>>:
                Set piPP = tDtD.getElementsByTagName("a")
                If piPP.Length > 0 Then
                mySplit = Split(piPP(0).href, ",", , vbTextCompare)
                    If UBound(mySplit) = 2 Then
                        ActiveSheet.Hyperlinks.Add Anchor:=Cells(I + 1, J + 1), Address:= _
                        Replace(myHL, "#####", Trim(mySplit(1)), , , vbTextCompare), TextToDisplay:=Cells(I + 1, J + 1).Value
                    End If
                End If
'<< End hLink
            J = J + 1
        Next tDtD
        I = I + 1: J = 0
    Next tRtR
    I = I + 1
Next myItm

Una volta che hai tutti i dati puoi estrarre /evidenziare quelli di tuo interesse e trascurare /cancellare gli altri.

Ciao

[daviluc61]

Anthony, grazie per la risposta, era ciò che volevo! C'è però un intoppo che non riesco a risolvere: nel foglio 2 ho estratto i vari indirizzi degli hyperlink. Adesso, attraverso un ciclo for... next prendo in successione i vari indirizzi e scarico i dati nel foglio 3. Se eseguo l'istruzione sottostante, i nuovi dati si sovrappongono ai primi. Ti chiedo: come posso accodare questi dati orizzontalmente, a partire dalla cella A1? Come posso modificare questa parte? Ti ringrazio

Codice: Seleziona tutto

Set Rng = Worksheets("Foglio2").Range(Range("A1"), Range("A1").End(xlDown))
For Each cel In Rng
    myURL = cel.Value   
    Set IE = CreateObject("InternetExplorer.Application")
With IE
.navigate myURL
.Visible = True
Do While .Busy: DoEvents: Loop
Do While .readyState <> 4: DoEvents: Loop
End With
myStart = Timer
Do
DoEvents
If Timer > myStart + 2 Or Timer < myStart Then Exit Do
Loop
I = 1
Worksheets("Foglio3").Activate
Set mycoll = IE.document.getElementsByTagName("TABLE")
For Each myItm In mycoll
    For Each tRtR In myItm.Rows
        For Each tDtD In tRtR.Cells
            picon = InStr(1, tDtD.classname, " icon", vbTextCompare)
            If picon > 0 Then
                Cells(I + 1, J + 1) = Left(tDtD.classname, picon) & tDtD.innerText
            Else
                Cells(I + 1, J + 1) = tDtD.innerText
            End If
            J = J + 1
        Next tDtD
        I = I + 1: J = 0
    Next tRtR
    I = I + 1
Next myItm
IE.Quit
Next cel

[Anthony47]

Intanto e' utile che IE sia persistente per tutto il ciclo, senza bisogno di terminarlo e ricrearlo in continuazione.
Toccheremo quindi questa parte di codice

Codice: Seleziona tutto

'Altro codice
For Each cel In Rng                                             '****
    myURL = cel.Value
    Set IE = CreateObject("InternetExplorer.Application")       '****
With IE
    .navigate myURL
    '
    'altro codice
    '
        I = I + 1: J = 0
    Next tRtR
    I = I + 1
    Next myItm
IE.Quit         '****
Next cel        '****

Invertiamo la posizione delle celle marcate **** e inseriamo le modifiche per poter "mettere in colonna", in questo modo:

Codice: Seleziona tutto

Set IE = CreateObject("InternetExplorer.Application")           '**** SPOST
For Each cel In Rng                                             '**** SPOST
    zz = zz + 1                             '2222 AGG
    myURL = cel.Value
With IE
    .navigate myURL
    '
    'altro codice
    '
        I = I + 1: J = (zz - 1) * 10        '2222 MOD
    Next tRtR
    I = I + 1: J = zz * 10                  '2222 MOD
    Next myItm
   
Next cel        '**** SPOST
IE.Quit         '**** SPOST


Sono evidenziate le righe SPOSTate, e le modifiche per la messa in colonna (1 riga AGGiunta e 2 righe MODificate)

Ti raccomando di inserire il tag "Code" attorno alle righe di "codice": selezioni le righe di codice, premi il pulsate "Code" che trovi appena sopra l'area in cui si scrive il testo del messaggio; se non lo vedi, allora sei in "Risposta veloce", devi premere "Editor completo" per avere tutti i tool di formattazione del messaggio.

Prova e fai sapere....

[daviluc61]

Anthony, grazie tanto. Ho risolto. Sei eccezionale per competenza e rara disponibilità. Ancora grazie

[daviluc61]

Scusami, Antony, se ritorno sull'argomento. Poichè sto provando a scaricare dal sito diretta.it, come posso modificare l'istruzione che segue (quella che, per intenderci, mi hai fornito per il sito betradar), affinchè mi compaiano, vicino ai minuti, la descrizione dell'icona?. Mi spiego meglio. Sto scaricando i vari tabellini delle partite (esempio: "https://www.diretta.it/partita/fotcEqLq/#informazioni-partita") e vorrei che mi compaiano oltre ai minuti e ai calciatori, anche il tipo di evento (sostituzione, goal,cartellino)


myURL = "https://www.diretta.it/partita/fotcEqLq/#informazioni-partita"
Set IE = CreateObject("InternetExplorer.Application")
With IE
.navigate myURL
.Visible = True
Do While .Busy: DoEvents: Loop
Do While .readyState <> 4: DoEvents: Loop
End With
myStart = Timer
Do
DoEvents
If Timer > myStart + 2 Or Timer < myStart Then Exit Do
Loop
I = 1
Worksheets("Foglio2").Activate
Set mycoll = IE.document.getElementsByTagName("TABLE")
For Each myItm In mycoll
For Each tRtR In myItm.Rows
For Each tDtD In tRtR.Cells
picon = InStr(1, tDtD.classname, " icon", vbTextCompare)
If picon > 0 Then
Cells(I + 1, J + 1) = Left(tDtD.classname, picon) & tDtD.innerText
Else
Cells(I + 1, J + 1) = tDtD.innerText
End If
J = J + 1
Next tDtD
I = I + 1: J = 0
Next tRtR
I = I + 1
Next myItm


Grazie (... con la speranza di non disturbarti ancora)

[Anthony47]

Queste automazioni sono sempre fatte su misura, secondo il sorgente html del sito; per dire che bisogna guardare il sorgente di www.diretta.it e vedere cosa si puo' riutilizzare.
Insomma ci vuole un po' piu' di tempo, devi aspettare...

[daviluc61]

non ci sono probemi, è già tanto ciò che ho ottenuto. Aspetterò con pazienza.

[daviluc61]

Gentilissimo Anthony,
posso confidare sulla tua disponibilità per risolvere il quesito che ti ho posto, inerente la descrizione dell'icona che scarico dalsito diretta.it?
Grazie ancora

[Anthony47]

Ho modificato la precedente BetRadar2 per poter estrarre le icone di diretta.it; il nuovo codice (che dovrebbe funzionare anche su betradar.com):

Codice: Seleziona tutto

Sub GetRadar3()
'Vedi http://www.pc-facile.com/forum/viewtopic.php?f=26&t=109246
Dim IE As Object
Dim myURL As String, myHL As String
Dim mySplit, tDtD, tRtR, tdIColl
Dim I As Long, J As Long, kI As Long, kIStr As String

myURL = "https://www.diretta.it/partita/fotcEqLq/#informazioni-partita"

'myURL = "http://stats.betradar.com/s4/?clientid=5&language=it#2_1,3_17,22_1,5_41264,9_fixtures,231_full,23_1"
myHL = "http://stats.betradar.com/s4/?clientid=5&language=it#2_1,3_17,22_1,5_41264,9_match,8_#####,178_2055,7_2061"
Set IE = CreateObject("InternetExplorer.Application")
'
With IE
    .navigate myURL
    .Visible = True
    Do While .Busy: DoEvents: Loop
    Do While .readyState <> 4: DoEvents: Loop
End With
'
myStart = Timer
Do
DoEvents
If Timer > myStart + 2 Or Timer < myStart Then Exit Do
Loop
I = 1
Worksheets("Foglio4").Activate
Range("A:G").Clear
Set mycoll = IE.document.getelementsbytagname("TABLE")
For Each myItm In mycoll
    For Each tRtR In myItm.Rows
        For Each tDtD In tRtR.Cells
            picon = InStr(1, tDtD.classname, " icon", vbTextCompare)
            If picon > 0 Then
                Cells(I + 1, J + 1) = Left(tDtD.classname, picon) & tDtD.innertext
            Else
            'per diretta.it>>:
                Set tdIColl = tDtD.getelementsbytagname("div")
                kIStr = ""
                If tdIColl.Length > 0 Then
                    For kI = 0 To tdIColl.Length - 1
                        If InStr(1, tdIColl(kI).classname, "icon-", vbTextCompare) > 0 Then
                            kIStr = ", " & Replace(tdIColl(kI).classname, "icon-box", "", , , vbTextCompare)
                            Exit For
                        End If
                    Next kI
                End If
            '<< per diretta.it
                Cells(I + 1, J + 1) = "'" & Trim(Replace(Replace(tDtD.innertext, Chr(10), " ", , , vbTextCompare), Chr(13), " ", , , vbTextCompare)) & kIStr
            End If
'Per hLink>>:
                Set piPP = tDtD.getelementsbytagname("a")
                If piPP.Length > 0 Then
                mySplit = Split(piPP(0).href, ",", , vbTextCompare)
                    If UBound(mySplit) = 2 Then
                        ActiveSheet.Hyperlinks.Add Anchor:=Cells(I + 1, J + 1), Address:= _
                        Replace(myHL, "#####", Trim(mySplit(1)), , , vbTextCompare), TextToDisplay:=Cells(I + 1, J + 1).Value
                    End If
                End If
'<< End hLink
            J = J + 1
        Next tDtD
        I = I + 1: J = 0
    Next tRtR
    I = I + 1
Next myItm

IE.Quit
Set IE = Nothing
Calculate
End Sub

Ciao

[daviluc61]

Eccezionale. Grazie tanto

[daviluc61]

Scusami Anthony se ti importuno nuovamente. Con la macro seguente io importo la pagina iniziale del sito diretta.it estraendo i dati del giorno "oggi". Come è possibile trasformare questa macro affinchè possa scaricare i dati dei giorni precedenti o successivi (per intenderci quelli che vengono fuori cliccando il menu a tendina posto in alto a destra della home page di diretta.it. Questo argomento, se non erro, è già stato affrontato e risolto, solo che non riesco più a trovare la discussione: Ti ringrazio anticipatamente

Codice: Seleziona tutto

Sub GetWebTab2()
Dim IE As Object, F As Long
Dim myRColl, myDColl, KK As Long, I As Long, J As Long, myColl, myR, myTD

myURL = "http://www.diretta.it"
Set IE = CreateObject("InternetExplorer.Application")

With IE
    .navigate myURL
    .Visible = True
    Do While .Busy: DoEvents: Loop           
    Do While .readyState <> 4: DoEvents: Loop 
End With

myStart = Timer                           
Do
    DoEvents
    If Timer > myStart + 2 Or Timer < myStart Then Exit Do
Loop

Application.Goto (Sheets("Foglio2").Range("A1"))       
Cells.Clear
Set myColl = IE.Document.getElementsbyTagName("TABLE")
For Each myItm In myColl
    Cells(I + 1, "A").Value = "TABELLA_" & KK: KK = KK + 1: I = I + 1
    For Each trtr In myItm.Rows
        For Each tdtd In trtr.Cells
            Cells(I + 1, J + 1) = tdtd.innertext
            J = J + 1
        Next tdtd
        I = I + 1: J = 0
           Next trtr
I = I + 2
Next myItm

Set myColl = IE.Document.getElementsbyTagName("iframe")
For F = 0 To myColl.Length - 1
If Left(myColl(F).ID, 7) = "myframe" Then
Set my2coll = myColl(F).contentDocument.getElementsbyTagName("table")
    For Each myItm In my2coll
    Cells(I + 1, "A").Value = "TABELLA_" & KK: KK = KK + 1: I = I + 1
        Set myRColl = myItm.getElementsbyTagName("tr")
        For Each myR In myRColl
            Set myDColl = myR.getElementsbyTagName("td")
            For Each myTD In myDColl
                Cells(I + 1, J + 1) = myTD.innertext
                J = J + 1
            Next myTD
            I = I + 1: J = 0
        Next myR
    I = I + 2
    Next myItm
End If
Next F

Set IE = Nothing
End Sub

[Anthony47]

In un'altra situazione avevo suggerito:

Codice: Seleziona tutto

Sub DirettaRis()
Dim IE As Object, myURL As String
'Dim myId As String, myCode As String
'
'myURL = "http://www.risultati.it/"
myURL = "https://www.diretta.it/"
If IE Is Nothing Then Set IE = CreateObject("InternetExplorer.Application")
With IE
    .Navigate myURL
    .Visible = True
    Do While .Busy: DoEvents: Loop    'Attesa not busy
    Do While .readyState <> 4: DoEvents: Loop 'Attesa documento
End With
 
myStart = Timer
Do  '1 sec prudenziale
    DoEvents
    If Timer > myStart + 1 Or Timer < myStart Then Exit Do
Loop
'
'

Set myItm = IE.document.getelementbyid("fscon")
'Vai alla gestione Giorni
myItm.getElementsByTagName("a")(6).Click    '<<< 0=Tutti, 1=Live, .... 6=Calendario
    Do While IE.Busy: DoEvents: Loop    'Attesa not busy
    Do While IE.readyState <> 4: DoEvents: Loop 'Attesa documento
Application.Wait (Now + TimeValue("0:00:04"))
'
'Seleziona un Giorno (0-14):
Set myItm = IE.document.getelementbyid("ifmenu-calendar-content")
myItm.getElementsByTagName("a")(7).Click    '<<< 0=-7gg, 1=-6gg,... 7=Oggi, etc
Application.Wait (Now + TimeValue("0:00:04"))
 
'Scaricare le tabelle:
Sheets("Foglio2").Select                '<<< Il foglio su cui leggere le tabelle
Range("A:P").ClearContents              '!!! !!! AZZERA FOGLIO CORRENTE SENZA PREAVVISO

Set myColl = IE.document.getElementsByTagName("TABLE")
'
For Each myItm In myColl
    For Each trtr In myItm.getElementsByTagName("tr")
        For Each tdtd In trtr.getElementsByTagName("td")
            Cells(myI + 1, myJ + 1) = tdtd.innerText
            myJ = myJ + 1
        Next tdtd
        myI = myI + 1: myJ = 0
    Next trtr
    myI = myI + 1
Next myItm
'
Range("A:Z").WrapText = False   '<<< Udattare il range se >A:Z
'< Fine importazione tabelle
'
'Stop
'
'Chiusura:
IE.Quit
Set IE = Nothing
End Sub

La selezione della data viene fatta nell'istruzione

Codice: Seleziona tutto

myItm.getElementsByTagName("a")(7).Click    '<<< 0=-7gg, 1=-6gg,... 7=Oggi, etc

Le possibili opzioni vanno da 0 a 14, con 7="Oggi", 6="ieri", 8="domani" e cosi' via

Ciao

[daviluc61]

Gentile e disponibile come sempre. Grazie

[daviluc61]

Gent.mo Anthony,
ritorno sull'argomento chiedendoti nuovamente aiuto. Con la macro sottostante io scarico i dati dal sito del myURL. Quando importo questi dati, mi manca però l'indicazione dei vari turni, sostituiti da una riga vuota. Come posso modificare la macro affinchè mi compaia l'indicazione dei vari turni? Ti ringrazio anticipatamente

Sub BetRadar()
'''Application.Calculation = xlCalculationManual
Dim IE As Object
Dim myURL As String, myHL As String
Dim mySplit, tDtD, tRtR
Dim I As Long, J As Long

myURL = "http://stats.betradar.com/s4/?clientid=5&language=it#2_1,3_17,22_1,5_41264,9_fixtures,231_full,23_1"
myHL = "http://stats.betradar.com/s4/?clientid=5&language=it#2_1,3_17,22_1,5_41264,9_match,8_#####,178_2055,7_2061"

Set IE = CreateObject("InternetExplorer.Application")

With IE
.navigate myURL
.Visible = True
Do While .Busy: DoEvents: Loop
Do While .readyState <> 4: DoEvents: Loop
End With
'
myStart = Timer
Do
DoEvents
If Timer > myStart + 2 Or Timer < myStart Then Exit Do
Loop

I = 1
Worksheets("Foglio1").Activate
Range("A:G").Clear
Set mycoll = IE.document.getElementsByTagName("TABLE")
For Each myItm In mycoll
For Each tRtR In myItm.Rows
For Each tDtD In tRtR.Cells
Cells(I + 1, J + 1) = tDtD.innerText
'Per hLink>>:
Set piPP = tDtD.getElementsByTagName("a")
If piPP.Length > 0 Then
mySplit = Split(piPP(0).href, ",", , vbTextCompare)
If UBound(mySplit) = 2 Then
ActiveSheet.Hyperlinks.Add Anchor:=Cells(I + 1, J + 1), Address:= _
Replace(myHL, "#####", Trim(mySplit(1)), , , vbTextCompare), TextToDisplay:=Cells(I + 1, J + 1).Value
End If
End If
'<< End hLink
J = J + 1
Next tDtD
I = I + 1: J = 0
Next tRtR
I = I + 1
Next myItm

IE.Quit
Set IE = Nothing
Calculate
End Sub