Valutazione 4.87/ 5 (100.00%) 5838 voti

Condividi:        

importare da web2

Vuoi potenziare i tuoi documenti Word? Non sai come si fa una macro in Excel? Devi creare una presentazione in PowerPoint?
Oppure sei passato a OpenOffice e non sei sicuro di come lavorare al meglio?

Moderatori: Anthony47, Flash30005

importare da web2

Postdi rombotuono » 15/05/19 20:43

buonasera
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
rombotuono
Utente Junior
 
Post: 24
Iscritto il: 09/11/18 17:27

Sponsor
 

Re: importare da web2

Postdi Anthony47 » 16/05/19 09:43

Da quell che vedo, e' necessario "incapsuare" il ciclo che ora si occupa di importare le tabelle (da in un ulteriore ciclo che si deve occupare di cambiare le pagine. Del tipo:
Codice: Seleziona tutto
For K = 1 To 10
    '
    'IL CODICE DEL CICLO ATTUALE
    '
    Set myColl = IE.document.getElementsByClassName("pageHld pager")(0).getElementsByTagName("a")
    If K >= myColl.Length Then Exit For
    myColl(K).Click
    Call IEReady1(IE, 3)
Next K


Insomma la Sub GetTabbbSubOptAll1 diventa:
Codice: Seleziona tutto
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 = True             'NON RACCOMANDO "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

For K = 1 To 10
    '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
   
    Set myColl = IE.document.getElementsByClassName("pageHld pager")(0).getElementsByTagName("a")
    If K >= myColl.Length Then Exit For
    myColl(K).Click
    Call IEReady1(IE, 3)
Next K
'
'Chiusura IE
IE.Quit
Set IE = Nothing
End Sub

Ciao
Anthony
Win7 + Office 2010 Ita; Win 7 + Office 2013 Ita
Xp + Office 2003 Ita
E voi cosa usate? (per istruzioni vedere viewtopic.php?f=26&t=97449)
Avatar utente
Anthony47
Moderatore
 
Post: 16316
Iscritto il: 21/03/06 16:03
Località: Ivrea

Re: importare da web2

Postdi rombotuono » 16/05/19 17:24

grazie
il lavoro lo svolge perfettamente

la trovo un po lenta chiedo se c'è la possibiltà di velocizzarla
grazie
rombotuono
Utente Junior
 
Post: 24
Iscritto il: 09/11/18 17:27

Re: importare da web2

Postdi rombotuono » 16/05/19 21:41

ciao
aggiungo alla mia risposta precedente
provando ho riscontrato
con questo
url https://www.scorespro.com/soccer/german ... /fixtures/
importa in parte poi
la macro si blocca su questa riga
Set myColl = IE.document.getElementsByClassName("pageHld pager")(0).getElementsByTagName("a")
grazie
rombotuono
Utente Junior
 
Post: 24
Iscritto il: 09/11/18 17:27

Re: importare da web2

Postdi Anthony47 » 17/05/19 12:38

Deve esserti chiaro che queste automazioni sono "abiti su misura", difficilmente calzano quando si modifica il target…
Comunque, l'adattamento anche all'ultima pagina si puo' ottenere modificando le aggiunte che avevo inserito:
Codice: Seleziona tutto
    I = I + 1
    Next myItm
'Questa parte modificata>>
    Set myColl = Nothing
    On Error Resume Next
        Set myColl = IE.document.getElementsByClassName("pageHld pager")(0).getElementsByTagName("a")
    On Error GoTo 0
    If myColl Is Nothing Then Exit For
'<<< fine parte modificata
    If K >= myColl.Length Then Exit For
    myColl(K).Click
    Call IEReady1(IE, 3)      '****
Next K

Quanto alla velocita' di esecuzione, a tuo rischio e pericolo puoi modificare quel 3 nell'istruzione marcata **** (vedi blocco precedente) portandolo a 0.5 e guadagnerai 10-15 secondi.

Ciao
Anthony
Win7 + Office 2010 Ita; Win 7 + Office 2013 Ita
Xp + Office 2003 Ita
E voi cosa usate? (per istruzioni vedere viewtopic.php?f=26&t=97449)
Avatar utente
Anthony47
Moderatore
 
Post: 16316
Iscritto il: 21/03/06 16:03
Località: Ivrea

Re: importare da web2

Postdi rombotuono » 17/05/19 13:15

grazie
gentilissimo
rombotuono
Utente Junior
 
Post: 24
Iscritto il: 09/11/18 17:27


Torna a Applicazioni Office Windows


Topic correlati a "importare da web2":


Chi c’è in linea

Visitano il forum: Nessuno e 10 ospiti