Importare data e altro da pagina web

[rombotuono]

Buonasera
sto cercando di aggiungere alcune righe alla macro funzionante usata diversi anni fa ma purtroppo con esito negativo
vorrei oltre a quello che già importa importare anche la data dell' incontro
allego file
https://ufile.io/qxy9kzzw
grazie

[Anthony47]

Perdona, dovresti almeno dire quale delle macro va presa in considerazione e, sul sito betexplorer.com, quale pagina viene letta e dove si trova la data che vuoi importare.
Ciao

[rombotuono]

grazie
la macro è macro importarisultati

https://www.betexplorer.com/soccer/braz ... a/results/

per ogni incontro già disputato vorrei importare questi dati
cliccando per esempio su Fortaleza - Corinthians vorrei importare : la data, risultato finale e risultato parziale
https://www.betexplorer.com/soccer/braz ... doEHa/#1x2

grazie

[Anthony47]

Ho trovato molto pesante decodificare la Sub ImportaRisultati, che processa come "stringhe" i risultati delle query che restituiscono testi formattati in html e che quindi potrebbero /dovrebbero essere considerati come html e processati tramite i relativi tag o i loro Xpath. Mi sono pero' ben guardato da modificare l'approccio, limitando la ricerca tramite tag html alle informazioni aggiuntive richieste.
A questo scopo ho inserito i blocchi compresi tra la riga >>> e la riga <<< nelle seguenti posizioni:

Codice: Seleziona tutto

Sub importarisultati()
'>>>
Dim html_Content As Object, COLL As Object
'<<<


Codice: Seleziona tutto

http1.send
Texthh = http1.responseText
Texthh = Replace(Texthh, Chr(34), "")
'>>>
Set html_Content = CreateObject("htmlfile")
html_Content.body.innerHTML = http1.responseText
'<<<
       
        con1 = "js-partial"


Codice: Seleziona tutto

        posin = posiz6
       
'>>>
Set COLL = html_Content.getElementById("match-date")
mysplit = Split(COLL.getAttribute("data-dt"), ",", , vbTextCompare)
Cells(x, 13) = DateSerial(mysplit(2), mysplit(1), mysplit(0)) + TimeSerial(mysplit(3), mysplit(4), 0)
Set COLL = html_Content.getElementById("js-score")
Cells(x, 14) = "'" & COLL.innerText
Set COLL = html_Content.getElementById("js-partial")
Cells(x, 15) = COLL.innerText
'<<<
50  Next t


Tre blocchi di istruzione in tutto; le righe prima di >>> e dopo <<< sono presenti nella tua macro originale, e sono inseriti per consentirti di identificare la posizione dei blocchi aggiunti
Le info aggiuntive sono inserite nelle colonne M:O

Non conoscendo come e' articolato il tuo file ho fatto un collaudo all'acqua di rose, quindi controlla bene cosa ti esce.

Ciao

[rombotuono]

grazie Anthony
funziona perfettamente
vorrei chiederti un altra cortesia
se si potrebbe snellire la macro eliminando la parte di codice che importa i dati da colonna f alla colonna k visto che con il tuo intervento vengono importati di nuovo.
grazie

[Anthony47]

grazie Anthony
funziona perfettamente
vorrei chiederti un altra cortesia
se si potrebbe snellire la macro eliminando la parte di codice che importa i dati da colonna f alla colonna k visto che con il tuo intervento vengono importati di nuovo.

Non voglio toccare la macro perche' faccio fatica a decodificarla (perche' contorta); mi limito quindi a suggerire di eliminare le istruzioni che compilano quelle colonne, che sono queste:

Codice: Seleziona tutto

        Cells(x, 6) = gsq1
        Cells(x, 7) = gsq2
        Cells(x, 8) = rsqh1
        If Cells(x, 8) = "" Then Cells(x, 8) = gsq1
        Cells(x, 9) = rsqa1
        If Cells(x, 9) = "" Then Cells(x, 9) = gsq2
        Cells(x, 10) = rsqh2
        If Cells(x, 10) = "" Then Cells(x, 10) = 0
        Cells(x, 11) = rsqa2
        If Cells(x, 11) = "" Then Cells(x, 11) = 0


Sono a meta' del codice, poco prima dell'ultimo mio blocco aggiunto; vanno cancellate

Ciao

[rombotuono]

grazie

[rombotuono]

'>>>
Set COLL = html_Content.getElementById("match-date")
buongiorno
Anthony
scusa ma per mancanza di tempo ho verificato soltanto in questi giorni la macro è risulta perfettamente funzionante ma nell elaborazione risulta lentissima
vorrei chiederti se è possibile implementare il codice che mi hai suggerito in questa macro che risulta abbastanza veloce
la macro è Importa_risultati
allego file
https://ufile.io/k57uexoa
ancora grazie

[Anthony47]

Finora mi sono limitato a inserire le prestazioni richieste nella tua macro, evitando di capire e decodificare il codice "funzionante".
Per qualsiasi intervento dovresti descrivere che cosa va fatto, cosa che non potrei fare guardando il codice attuale o il risultato ottenuto sul foglio
Ciao

[rombotuono]

ciao
Anthony
la macro nel file importa dal sito
https://www.betexplorer.com/soccer/braz ... a/results/
i risultati
da questo link vorrei importare
https://www.betexplorer.com/soccer/braz ... /2cU1j0ad/
questi dati parziali
(0:2, 1:0)
che la macro nel file d esempio non importa
chiedevo se era possibile implementare per ogni incontro anche i parziali
grazie

[Anthony47]

Le informazioni che vuoi importare sono i risultati intermedi di ogni partita; questo dato non c'e' nella tabella principale che la query va a leggere, ma bisogna aprire una pagina diversa per ogni partita.
Per me il modo piu' lineare per ottenere il tutto e' leggere le pagine web e catturare il dato, in sostituzione della webquery che usi al momento:
Cosa che si puo' fare con una macro come questa:

Codice: Seleziona tutto

#If VBA7 Then       '!!! ON  TOP  OF  THE  VBA  MODULE   !!!!
    Declare PtrSafe Sub Sleep Lib "kernel32" (ByVal dwMilliseconds As LongPtr)
#Else
    Declare Sub Sleep Lib "kernel32" (ByVal dwMilliseconds As Long)
#End If

Sub GetByAnth()
Dim IE As Object, IE2 As Object
Dim AColl As Object, BColl As Object, myTbl As Object, myBItm As Object
Dim tCol As Object
'
Set IE = CreateObject("InternetExplorer.Application")
Set IE2 = CreateObject("InternetExplorer.Application")
Range("A:G").Clear
myurl = "https://www.betexplorer.com/soccer/brazil/serie-a/results/"
IE.Visible = True
resp = GimmePage(myurl, IE)
If resp <> 0 Then Stop
Set AColl = Nothing
Set myTbl = IE.document.getElementById("js-leagueresults-all")
If myTbl Is Nothing Then GoTo TERM
On Error Resume Next
Set AColl = myTbl.getElementsByTagName("tr")
Debug.Print "AA: " & AColl.Length
'
For i = 0 To AColl.Length - 1
    j = 0
    For Each tCol In AColl(i).Cells
       j = j + 1
       Cells(i + 2, j).Value = "'" & tCol.innerText
            If InStr(1, tCol.outerHTML, "href=", vbTextCompare) > 0 And j = 1 Then
                ActiveSheet.Hyperlinks.Add Anchor:=Cells(i + 2, j), Address:=tCol.getElementsByTagName("a")(0).href, _
                TextToDisplay:=Cells(i + 2, j).Value
                Debug.Print "CC", Timer
                resp = GimmePage(tCol.getElementsByTagName("a")(0).href, IE2)
                If resp = 0 Then
''                    IE2.Visible = True
                    Set myBItm = Nothing
                    Set myBItm = IE2.document.getElementById("js-partial")
                    If myBItm Is Nothing Then
                        Cells(i + 2, "G").Value = "?? Missing"
                    Else
                        Cells(i + 2, "G").Value = myBItm.innerText
                    End If
                End If
                Debug.Print "DD", Timer
            End If
    Next tCol
    DoEvents
    Debug.Print "EE", Timer
Next i
MsgBox ("Importate " & i - 1 & " righe")
'
TERM:
On Error Resume Next
IE.Quit
IE2.Quit
Set IE = Nothing
Set IE2 = Nothing
End Sub

Function GimmePage(ByVal LUrl As String, LIE As Object) As Long
Dim mTim As Single
    With LIE
        .navigate LUrl
        mytim = Timer
        Sleep 100
        Do
            Sleep 30
            If .busy = False And .readyState = 4 Then Exit Do
            If Timer > (mytim + 10) Then
                If .readyState <> 4 Then GimmePage = 10
                If .busy Then WaitPage = GimmePage + 1
                Exit Do
            End If
        DoEvents
        Loop
    End With
End Function


Il codice va messo in un modulo standard inizialmente vuoto, in modo che le Declare iniziali si trovino prima di ogni Sub.
Poi si seleziona il foglio su cui saranno scritti i risultati e va lanciata la Sub GetByAnth; ATTENZIONE: le colonne A:G del foglio vengono azzerate senza preavviso.

Ovviamente aprire in sequenza 140 pagine web richiedera' il suo tempo, quindi armati di pazienza.

Ciao

[rombotuono]

grazie
Anthony47
funziona perfettamente
un ultima cosa
avrei la necessita di prelevare questo link
https://www.betexplorer.com/soccer/braz ... a/results/
direttamente da una cella per esempio m1
perchè devo automatizzare diversi link
cioè sostituire questo
myURL = "https://www.betexplorer.com/soccer/brazil/serie-a/results/"

[Anthony47]

grazie
Anthony47
funziona perfettamente
un ultima cosa
avrei la necessita di prelevare questo link
https://www.betexplorer.com/soccer/braz ... a/results/
direttamente da una cella per esempio m1
perchè devo automatizzare diversi link
cioè sostituire questo
myURL = "https://www.betexplorer.com/soccer/brazil/serie-a/results/"

Allora userai, ad esempio:

Codice: Seleziona tutto

myURL = Range("M1").Value

Presuppone che l'URL completo sia scritto in M1 del foglio attivo

Ciao

[rombotuono]

avevo inserito lo stesso codice ma non funzionava a causa del link incompleto
inserendo anche il tuo suggerimento stesso problema risolto con la correzione del link.

ho provato a traslare il tutto in colonna aa -- ag ma i dati sono incompleti perchè mancano gli Hyperlinks quindi non riesco a importare i parziali.
in definitiva vorrei traslare il tutto
grazie ancora

[Anthony47]

Se vuoi allineare i risultati in AA e successive allora devi modificare alcune istruzioni, che ti segnalo (quelle marcate MMM, le altre sono riportate solo per inquadrare la posizione):

Codice: Seleziona tutto

Set IE2 = CreateObject("InternetExplorer.Application")
Range("AA:AG").Clear                               'MMM


Codice: Seleziona tutto

 For i = 0 To AColl.Length - 1
    j = 26                                          'MMM
    For Each tCol In AColl(i).Cells
       j = j + 1
       Cells(i + 2, j).Value = "'" & tCol.innerText
            If InStr(1, tCol.outerHTML, "href=", vbTextCompare) > 0 And j = 27 Then      'MMM
                ActiveSheet.Hyperlinks.Add Anchor:=Cells(i + 2, j), Address:=tCol.getElementsByTagName("a")(0).href, _
                TextToDisplay:=Cells(i + 2, j).Value


Codice: Seleziona tutto

                    If myBItm Is Nothing Then
                        Cells(i + 2, "AG").Value = "?? Missing"         'MMM
                    Else
                        Cells(i + 2, "AG").Value = myBItm.innerText     'MMM
                    End If

Ciao

[rombotuono]

grazie