Condividi:        

Estarre dati da prosoccer.eu

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

Estarre dati da prosoccer.eu

Postdi apocrimata75 » 18/04/16 18:06

Ciao ragazzi, vorrei avvalermi del vs aiuto (sempre valido) per estrarre dei dati dalla pagina: http://www.prosoccer.eu/football/

Ho provato la macro di un mio precedente post che scaricava da "prosoccer.gr", ma non funziona. Grazie per qualsiasi aiuto in merito.
Windows 7 - Office 2010
apocrimata75
Utente Senior
 
Post: 189
Iscritto il: 28/05/11 13:22

Sponsor
 

Re: Estarre dati da prosoccer.eu

Postdi apocrimata75 » 23/04/16 18:50

Ciao ragazzi, nessuno ha un'idea su come estrarre i dati? L'importazione normale trasferisce tutti i dati in un'unica colonna, difficile da formattare.
Windows 7 - Office 2010
apocrimata75
Utente Senior
 
Post: 189
Iscritto il: 28/05/11 13:22

Re: Estarre dati da prosoccer.eu

Postdi Flash30005 » 24/04/16 02:54

Li puoi importare con una query web
quindi attivi il registratore di macro ed effettui l'operazione di inserimento dati da web
alla fine fermi la registrazione e avrai il codice per importare i dati
ora, però, dovresti distribuire i dati come ti occorrono
e anche queste operazioni le puoi registrare
una volta ottenuto il codice potrai rendere tutto in maniera automatica


ciao
Flash
Win10 + Office 2010 Ita
"Fotografica" al servizio dell'immagine
Avatar utente
Flash30005
Moderatore
 
Post: 8517
Iscritto il: 27/09/07 11:44
Località: Roma +o-

Re: Estarre dati da prosoccer.eu

Postdi apocrimata75 » 24/04/16 11:31

Il risultato della query sarebbe questo

Immagine

a fronte di un desiderato così

Immagine
Windows 7 - Office 2010
apocrimata75
Utente Senior
 
Post: 189
Iscritto il: 28/05/11 13:22

Re: Estarre dati da prosoccer.eu

Postdi ricky53 » 25/04/16 00:28

Ciao,
dopo aver effettuato l'importazione dei dati dal sito (i dati saranno come li ha proposti tu nella prima immagine)

Ipotizziamo che i dati di partenza siano in colonna "A" del foglio 1 a partire dalla riga "42" e che i dati "trasposti" vadano scritti in colonna "A" del foglio2


Se la risposta è "SI" allora prova ad eseguire questa macro
Codice: Seleziona tutto
Sub Copia_e_Trasponi()
' http://www.prosoccer.eu/football/

    Dim UR As Integer, I As Integer, j As Integer, X As Integer, WS_In As Worksheet, WS_Out As Worksheet, Dato As String
   
    Application.ScreenUpdating = False
    Set WS_In = Sheets("Foglio1")
    Set WS_Out = Sheets("Foglio2")
    UR = WS_Out.Range("A" & Rows.Count).End(xlUp).Row
    WS_Out.Range("A1:Q" & UR).ClearContents
    WS_Out.Range("D:D,P:P,Q:Q").NumberFormat = "@"
    WS_Out.Columns("D:D").HorizontalAlignment = xlLeft
    WS_Out.Range("H:K,N:O").NumberFormat = "0.00"
    WS_Out.Range("F:F").NumberFormat = "0"
   
    WS_Out.Range("A1") = "league"
    WS_Out.Range("B1") = "ko"
    WS_Out.Range("C1") = "Match"
    WS_Out.Range("D1") = "tip"
    WS_Out.Range("F1") = "%"
    WS_Out.Range("I1") = "1"
    WS_Out.Range("J1") = "X"
    WS_Out.Range("K1") = "2"
    WS_Out.Range("N1") = "u/o"
    WS_Out.Range("O1") = "2.5"
    WS_Out.Range("P1") = "CS"
    WS_Out.Range("Q1") = "FT"
   
    UR = WS_In.Range("A" & Rows.Count).End(xlUp).Row
    X = 2
    For I = 50 To UR Step 10  ' <<======= nella cella  "A50"  iniziano i dati
        WS_In.Range("A" & I & ":A" & I + 3).Copy
        WS_Out.Range("A" & X).PasteSpecial Paste:=xlPasteAll, Operation:=xlNone, SkipBlanks:= _
            False, Transpose:=True
        Dato = Left(WS_In.Range("A" & I + 4), 2)
        WS_Out.Range("E" & X) = Left(WS_In.Range("A" & I + 4), 2)
        WS_Out.Range("F" & X) = Mid(WS_In.Range("A" & I + 4), 4, 2)
        WS_Out.Range("G" & X) = Mid(WS_In.Range("A" & I + 4), 7, 2)
        WS_Out.Range("H" & X) = Left(Replace(WS_In.Range("A" & I + 5), Chr(160), ""), 4)
        WS_Out.Range("I" & X) = Mid(Replace(WS_In.Range("A" & I + 5), Chr(160), ""), 6, 4)
        WS_Out.Range("J" & X) = Mid(Replace(WS_In.Range("A" & I + 5), Chr(160), ""), 11, 4)
        WS_Out.Range("K" & X) = Mid(Replace(WS_In.Range("A" & I + 5), Chr(160), ""), 16, 4)
           
        WS_Out.Range("L" & X) = Left(WS_In.Range("A" & I + 6), 2)
        WS_Out.Range("M" & X) = Right(WS_In.Range("A" & I + 6), 2)
       
        WS_Out.Range("N" & X) = Left(WS_In.Range("A" & I + 7), 4)
        WS_Out.Range("O" & X) = Mid(WS_In.Range("A" & I + 7), 7, 4)
       
        WS_Out.Range("P" & X) = Format(Mid(WS_In.Range("A" & I + 8), 4, 3), "@")
       
        WS_Out.Range("Q" & X) = Format(Mid(WS_In.Range("A" & I + 9), 6, 3), "@")
       
        X = X + 1
    Next I
    WS_Out.Columns("D:D").HorizontalAlignment = xlLeft
   
    Application.ScreenUpdating = False
    MsgBox "E' stata effettuata la trasposizione dei dati"
End Sub
Dice il vecchio saggio provare e riprovare è l'unica strada per imparare

Più chiara è la vostra spiegazione
Più immediata sarà la nostra soluzione


. . . . . . . . . .
S.O. W10; Office 2003-10-13-16-19
Avatar utente
ricky53
Utente Senior
 
Post: 4565
Iscritto il: 11/04/09 19:29
Località: Italia

Re: Estarre dati da prosoccer.eu

Postdi apocrimata75 » 25/04/16 10:08

Si inizia a vedere qualcosa, il risultato però è questo

Immagine
Windows 7 - Office 2010
apocrimata75
Utente Senior
 
Post: 189
Iscritto il: 28/05/11 13:22

Re: Estarre dati da prosoccer.eu

Postdi apocrimata75 » 25/04/16 10:19

Diciamo così

Immagine
Windows 7 - Office 2010
apocrimata75
Utente Senior
 
Post: 189
Iscritto il: 28/05/11 13:22

Re: Estarre dati da prosoccer.eu

Postdi apocrimata75 » 25/04/16 10:33

Codice: Seleziona tutto
Sub Copia_e_Trasponi()
' http://www.prosoccer.eu/football/

    Dim UR As Integer, I As Integer, j As Integer, X As Integer, WS_In As Worksheet, WS_Out As Worksheet, Dato As String
   
    Application.ScreenUpdating = False
    Set WS_In = Sheets("betpredict")
    Set WS_Out = Sheets("betpredict2")
    UR = WS_Out.Range("A" & Rows.Count).End(xlUp).Row
    WS_Out.Range("A1:Q" & UR).ClearContents
       
    WS_Out.Range("A1") = "league"
    WS_Out.Range("B1") = "Match"
    WS_Out.Range("C1") = "Tip"
    WS_Out.Range("D1") = "1x2"
    WS_Out.Range("F1") = "1X2 @"
    WS_Out.Range("I1") = "Over Under %"
    WS_Out.Range("J1") = "Over Under @"
    WS_Out.Range("K1") = "Ris esatto"
    WS_Out.Range("L1") = "Esito"
   
   
    UR = WS_In.Range("A" & Rows.Count).End(xlUp).Row
    X = 2
    For I = 50 To UR Step 10  ' <<======= nella cella  "A50"  iniziano i dati
        WS_In.Range("A" & I & ":A" & I + 3).Copy
        WS_Out.Range("A" & X).PasteSpecial Paste:=xlPasteAll, Operation:=xlNone, SkipBlanks:= _
            False, Transpose:=True
        Dato = Left(WS_In.Range("A" & I + 4), 2)
        WS_Out.Range("E" & X) = Left(WS_In.Range("A" & I + 4), 2)
        WS_Out.Range("F" & X) = Mid(WS_In.Range("A" & I + 4), 4, 2)
        WS_Out.Range("G" & X) = Mid(WS_In.Range("A" & I + 4), 7, 2)
        WS_Out.Range("H" & X) = Left(Replace(WS_In.Range("A" & I + 5), Chr(160), ""), 4)
        WS_Out.Range("I" & X) = Mid(Replace(WS_In.Range("A" & I + 5), Chr(160), ""), 6, 4)
        WS_Out.Range("J" & X) = Mid(Replace(WS_In.Range("A" & I + 5), Chr(160), ""), 11, 4)
        WS_Out.Range("K" & X) = Mid(Replace(WS_In.Range("A" & I + 5), Chr(160), ""), 16, 4)
           
        WS_Out.Range("L" & X) = Left(WS_In.Range("A" & I + 6), 2)
       
       
       
        X = X + 1
    Next I
    WS_Out.Columns("D:D").HorizontalAlignment = xlLeft
   
    Application.ScreenUpdating = False
    MsgBox "E' stata effettuata la trasposizione dei dati"
End Sub



dopo le modifiche

Immagine
Windows 7 - Office 2010
apocrimata75
Utente Senior
 
Post: 189
Iscritto il: 28/05/11 13:22

Re: Estarre dati da prosoccer.eu

Postdi apocrimata75 » 25/04/16 10:50

Ho tolto alcune cose e modificato la macro, il rigo 2 è perfetto, ma da A3 non va bene, manca la "league"

Codice: Seleziona tutto
Sub Copia_e_Trasponi()
' http://www.prosoccer.eu/football/

    Dim UR As Integer, I As Integer, j As Integer, X As Integer, WS_In As Worksheet, WS_Out As Worksheet, Dato As String
   
    Application.ScreenUpdating = False
    Set WS_In = Sheets("betpredict")
    Set WS_Out = Sheets("betpredict2")
    UR = WS_Out.Range("A" & Rows.Count).End(xlUp).Row
    WS_Out.Range("A1:Q" & UR).ClearContents
       
    WS_Out.Range("A1") = "league"
    WS_Out.Range("B1") = "Match"
    WS_Out.Range("C1") = "Tip"
    WS_Out.Range("D1") = "1x2"
    WS_Out.Range("F1") = "1X2 @"
    WS_Out.Range("I1") = "Over Under %"
    WS_Out.Range("J1") = "Over Under @"
    WS_Out.Range("K1") = "Ris esatto"
    WS_Out.Range("L1") = "Esito"
   
   
    UR = WS_In.Range("A" & Rows.Count).End(xlUp).Row
    X = 2
    For I = 50 To UR Step 10  ' <<======= nella cella  "A50"  iniziano i dati
        WS_In.Range("A" & I & ":A" & I + 8).Copy
        WS_Out.Range("A" & X).PasteSpecial Paste:=xlPasteAll, Operation:=xlNone, SkipBlanks:= _
            False, Transpose:=True
        Dato = Left(WS_In.Range("A" & I + 4), 3)
       
       
       
       
        X = X + 1
    Next I
    WS_Out.Columns("D:D").HorizontalAlignment = xlLeft
   
    Application.ScreenUpdating = False
    MsgBox "E' stata effettuata la trasposizione dei dati"
End Sub


Immagine
Windows 7 - Office 2010
apocrimata75
Utente Senior
 
Post: 189
Iscritto il: 28/05/11 13:22

Re: Estarre dati da prosoccer.eu

Postdi Flash30005 » 25/04/16 11:41

Prova questa
Codice: Seleziona tutto
Sub Copia_e_Trasponi()
' http://www.prosoccer.eu/football/

    Dim UR As Integer, I As Integer, j As Integer, X As Integer, WS_In As Worksheet, WS_Out As Worksheet, Dato As String
   
    Application.ScreenUpdating = False
    Set WS_In = Sheets("betpredict")
    Set WS_Out = Sheets("betpredict2")
    UR = WS_Out.Range("A" & Rows.Count).End(xlUp).Row
    WS_Out.Range("A1:Q" & UR).ClearContents
       
    WS_Out.Range("A1") = "league"
    WS_Out.Range("B1") = "Match"
    WS_Out.Range("C1") = "Tip"
    WS_Out.Range("D1") = "1x2"
    WS_Out.Range("F1") = "1X2 @"
    WS_Out.Range("I1") = "Over Under %"
    WS_Out.Range("J1") = "Over Under @"
    WS_Out.Range("K1") = "Ris esatto"
    WS_Out.Range("L1") = "Esito"
   
   
    UR = WS_In.Range("A" & Rows.Count).End(xlUp).Row
    X = 2
    For I = 1 To UR 'Step 10  ' <<======= nella cella  "A50"  iniziano i dati
        If WS_In.Range("A" & I).Value Like "*:*" Then
            WS_In.Range("A" & I & ":A" & I + 8).Copy
            WS_Out.Range("A" & X).PasteSpecial Paste:=xlPasteAll, Transpose:=True
            Dato = Left(WS_In.Range("A" & I + 4), 3)
            X = X + 1
        End If
    Next I
    WS_Out.Columns("D:D").HorizontalAlignment = xlLeft
   
    Application.ScreenUpdating = False
    MsgBox "E' stata effettuata la trasposizione dei dati"
End Sub

Bisogna ancora sistemare qualcosa ma almeno inserisce la lega nella colonna A e crea un record per ogni incontro


ciao
Flash
Win10 + Office 2010 Ita
"Fotografica" al servizio dell'immagine
Avatar utente
Flash30005
Moderatore
 
Post: 8517
Iscritto il: 27/09/07 11:44
Località: Roma +o-

Re: Estarre dati da prosoccer.eu

Postdi apocrimata75 » 25/04/16 14:43

E' perfetta così... Grazie mille.

Se posso approfittare, una formula per "estrarre" il nome delle squadre, senza parentesi tonda, esempio: (20), visto che il formato non è sempre uguale? Per chiarire, in alcune c'è la posizione tra parentesi, in altre no.

Immagine

Con questa formula pensavo di aver risolto:
Codice: Seleziona tutto
=SE.ERRORE(STRINGA.ESTRAI(B16;1; TROVA(" (";B16));STRINGA.ESTRAI(B16;1; TROVA(" -";B16)))


Ma, come nel rigo 16, crea un errore, vedi foto. Cioè arriva fino alla prima parentesi tona della seconda squadra

Immagine
Windows 7 - Office 2010
apocrimata75
Utente Senior
 
Post: 189
Iscritto il: 28/05/11 13:22

Re: Estarre dati da prosoccer.eu

Postdi Anthony47 » 25/04/16 21:12

Ora che hai gia' piu' soluzioni, ti segnalo anche questa variante di una delle tante macro sviluppate per accedere a questi siti sulla base del codice html sorgente della pagina, sviluppata per puro scopo ludico:
Codice: Seleziona tutto
Sub GetProsoccEu()
'
myURL = "http://www.prosoccer.eu/football/"     '<<<<
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  'attesa addizionale
Do
    DoEvents
    If Timer > myStart + 2 Or Timer < myStart Then Exit Do
Loop

Set mycoll = IE.document.getelementbyid("thetable")
Set my2coll = mycoll.getelementsbytagname("span")

For Each myspan In my2coll
DoEvents
    If myspan.classname = "comp" Then I = I + 1: J = 0
    If Left(myspan.classname, 5) <> "" Then
        Cells(I, J + 1).Value = myspan.innertext
        J = J + 1
    End If
Next myspan
'Stop     'Vedi testo
'
'Chiusura IE
IE.Quit
Set IE = Nothing
End Sub

Essa posiziona i dati nel foglio attivo, da cella A1 in avanti, sovrascrivendo senza preavviso i dati presenti.
Le celle del foglio, per evitare errate trascizioni, deve preventivamente essere stato formattato come Testo.
Fatene buon uso; finche' dura...

Ciao
Avatar utente
Anthony47
Moderatore
 
Post: 19196
Iscritto il: 21/03/06 16:03
Località: Ivrea

Re: Estarre dati da prosoccer.eu

Postdi apocrimata75 » 26/04/16 17:47

Grande Anthony. Funziona alla perfezione.......
Windows 7 - Office 2010
apocrimata75
Utente Senior
 
Post: 189
Iscritto il: 28/05/11 13:22

Re: Estarre dati da prosoccer.eu

Postdi Flash30005 » 28/04/16 05:33

Volendo rendere i dati più immediati
ho aggiunto questa routine
Codice: Seleziona tutto
Private Sub Formatta()
    Rows("1:1").Insert Shift:=xlDown
    Range("A1") = "Camp"
    Range("C1") = "Ora"
    Range("D1") = "Casa"
    Range("F1") = "FuoriC"
    Range("G1") = "Tip"
    Range("H1") = "'%1"
    Range("I1") = "'%X"
    Range("J1") = "'%2"
    Range("K1") = "Q1"
    Range("L1") = "Q1"
    Range("M1") = "QX"
    Range("N1") = "Q2"
    Range("K1") = "Qtip"
    Range("O1") = "%U"
    Range("Q1") = "%O"
    Range("R1") = "QU/O"
    Range("R1") = "QU"
    Range("T1") = "QO"
    Range("V1") = "RisEsP"
    Range("W1") = "RisEs??"
    Range("Z1") = "RisFin"
    Range("B:B,P:P,S:S,U:U,X:Y").Delete Shift:=xlToLeft
    Columns("F:T").HorizontalAlignment = xlRight
    Cells.EntireColumn.AutoFit
    ColFin = 10092390
    UR = Range("T" & Rows.Count).End(xlUp).Row
    For RR = 2 To UR
        Range("T" & RR).Value = "'" & Trim(Range("T" & RR).Value)
        Range("B" & RR).Value = Format(DateAdd("h", -1, Range("B" & RR).Value), "hh:mm")
        If Range("T" & RR).Value <> "" Then
            Range("T" & RR).Interior.Color = 52479
            RisFinale = Range("T" & RR).Value
            RisFR1 = Trim(Mid(RisFinale, InStr(RisFinale, "-") + 1, Len(RisFinale)))
            RisFR2 = Trim(Mid(RisFinale, 1, InStr(RisFinale, "-") - 1))
            SRis = Val(RisFR1) + Val(RisFR1)
            If RisFinale = Trim(Range("R" & RR).Value) Then Range("R" & RR).Interior.Color = ColFin
            If RisFinale = Trim(Range("S" & RR).Value) Then Range("S" & RR).Interior.Color = ColFin
            If RisFR1 = RisFR2 Then
             If Range("F" & RR).Value Like "*X*" Then Range("F" & RR).Interior.Color = ColFin
                Range("H" & RR).Interior.Color = ColFin
                Range("L" & RR).Interior.Color = ColFin
            GoTo saltaRF
            End If
            If RisFR1 > RisFR2 Then
                If Range("F" & RR).Value Like "1*" Then Range("F" & RR).Interior.Color = ColFin
                Range("G" & RR).Interior.Color = ColFin
                Range("K" & RR).Interior.Color = ColFin
            Else
                If Range("F" & RR).Value Like "*2" Then Range("F" & RR).Interior.Color = ColFin
                Range("I" & RR).Interior.Color = ColFin
                Range("M" & RR).Interior.Color = ColFin
            End If
saltaRF:
            If SRis > 2 Then
                Range("O" & RR).Interior.Color = ColFin
                Range("Q" & RR).Interior.Color = ColFin
            Else
                Range("N" & RR).Interior.Color = ColFin
                Range("P" & RR).Interior.Color = ColFin
            End If
        End If

    Next RR
End Sub


Che richiamerai a fine macro di Anthony
nel punto indicato
Codice: Seleziona tutto
'
'Chiusura IE  '<<<<<<<<<<<< esistente
IE.Quit         '<<<<<<<<<<<< esistente
Set IE = Nothing   '<<<<<<<<<<<< esistente
Formatta         '<<<<<<<<<<<<<<<<<<< aggiungi qui
End Sub


Mi risulta, comunque. una colonna "Fantasma" di risultati esatti (la colonna "S") che non è visibile se si accede al sito (???)
E come risultati sono più attendibili di quelli proposti
Vuoi vedere che potrai fare Bingo!??? :lol:
Flash
Win10 + Office 2010 Ita
"Fotografica" al servizio dell'immagine
Avatar utente
Flash30005
Moderatore
 
Post: 8517
Iscritto il: 27/09/07 11:44
Località: Roma +o-

Re: Estarre dati da prosoccer.eu

Postdi apocrimata75 » 28/04/16 07:46

Fermo restando che le due soluzioni vanno benissimo, ho provato ho copiato l'ultima di Anthony con la formattazione di flash.

Il risultato è come da immagine acclusa (non posso usare postimage.org), da sistemare nella formattazione, e restituisce il messaggio di errore

[url]<a href="http://image.forumfree.it/8/2/5/0/3/1/3/1461825549.jpg" target="_blank"><img src="http://image.forumfree.it/8/2/5/0/3/1/3/t/1461825549.jpg" alt="file errore"></a>[/url]

[img]<a%20href="http://image.forumfree.it/8/2/5/0/3/1/3/1461825549.jpg"%20target="_blank"><img%20src="http://image.forumfree.it/8/2/5/0/3/1/3/t/1461825549.jpg"%20alt="file%20errore"></a>[/img]
<a href="http://image.forumfree.it/8/2/5/0/3/1/3/1461825549.jpg" target="_blank"><img src="http://image.forumfree.it/8/2/5/0/3/1/3/t/1461825549.jpg" alt="file errore"></a>

Codice: Seleziona tutto
Sub GetProsoccEu()
'
myUrl = "http://www.prosoccer.eu/football/"     '<<<<
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  'attesa addizionale
Do
    DoEvents
    If Timer > myStart + 2 Or Timer < myStart Then Exit Do
Loop

Set myColl = IE.document.getElementById("thetable")
Set my2coll = myColl.getElementsByTagName("span")

For Each myspan In my2coll
DoEvents
    If myspan.className = "comp" Then i = i + 1: J = 0
    If Left(myspan.className, 5) <> "" Then
        Cells(i, J + 1).Value = myspan.innerText
        J = J + 1
    End If
Next myspan
'Stop     'Vedi testo
'
'Chiusura IE
IE.Quit
Set IE = Nothing
Formatta
End Sub
Private Sub Formatta()
    Rows("1:1").Insert Shift:=xlDown
    Range("A1") = "Camp"
    Range("C1") = "Ora"
    Range("D1") = "Casa"
    Range("F1") = "FuoriC"
    Range("G1") = "Tip"
    Range("H1") = "'%1"
    Range("I1") = "'%X"
    Range("J1") = "'%2"
    Range("K1") = "Q1"
    Range("L1") = "Q1"
    Range("M1") = "QX"
    Range("N1") = "Q2"
    Range("K1") = "Qtip"
    Range("O1") = "%U"
    Range("Q1") = "%O"
    Range("R1") = "QU/O"
    Range("R1") = "QU"
    Range("T1") = "QO"
    Range("V1") = "RisEsP"
    Range("W1") = "RisEs??"
    Range("Z1") = "RisFin"
    Range("B:B,P:P,S:S,U:U,X:Y").Delete Shift:=xlToLeft
    Columns("F:T").HorizontalAlignment = xlRight
    Cells.EntireColumn.AutoFit
    ColFin = 10092390
    UR = Range("T" & Rows.Count).End(xlUp).Row
    For RR = 2 To UR
        Range("T" & RR).Value = "'" & Trim(Range("T" & RR).Value)
        Range("B" & RR).Value = Format(DateAdd("h", -1, Range("B" & RR).Value), "hh:mm")
        If Range("T" & RR).Value <> "" Then
            Range("T" & RR).Interior.Color = 52479
            RisFinale = Range("T" & RR).Value
            RisFR1 = Trim(Mid(RisFinale, InStr(RisFinale, "-") + 1, Len(RisFinale)))
            RisFR2 = Trim(Mid(RisFinale, 1, InStr(RisFinale, "-") - 1))
            SRis = Val(RisFR1) + Val(RisFR1)
            If RisFinale = Trim(Range("R" & RR).Value) Then Range("R" & RR).Interior.Color = ColFin
            If RisFinale = Trim(Range("S" & RR).Value) Then Range("S" & RR).Interior.Color = ColFin
            If RisFR1 = RisFR2 Then
             If Range("F" & RR).Value Like "*X*" Then Range("F" & RR).Interior.Color = ColFin
                Range("H" & RR).Interior.Color = ColFin
                Range("L" & RR).Interior.Color = ColFin
            GoTo saltaRF
            End If
            If RisFR1 > RisFR2 Then
                If Range("F" & RR).Value Like "1*" Then Range("F" & RR).Interior.Color = ColFin
                Range("G" & RR).Interior.Color = ColFin
                Range("K" & RR).Interior.Color = ColFin
            Else
                If Range("F" & RR).Value Like "*2" Then Range("F" & RR).Interior.Color = ColFin
                Range("I" & RR).Interior.Color = ColFin
                Range("M" & RR).Interior.Color = ColFin
            End If
saltaRF:
            If SRis > 2 Then
                Range("O" & RR).Interior.Color = ColFin
                Range("Q" & RR).Interior.Color = ColFin
            Else
                Range("N" & RR).Interior.Color = ColFin
                Range("P" & RR).Interior.Color = ColFin
            End If
        End If

    Next RR
End Sub
Windows 7 - Office 2010
apocrimata75
Utente Senior
 
Post: 189
Iscritto il: 28/05/11 13:22

Re: Estarre dati da prosoccer.eu

Postdi apocrimata75 » 28/04/16 10:02

Per Flash,
ti confermo la presenza di una colonna nascosta estrapolata e non presente sul sito.
Windows 7 - Office 2010
apocrimata75
Utente Senior
 
Post: 189
Iscritto il: 28/05/11 13:22

Re: Estarre dati da prosoccer.eu

Postdi Flash30005 » 28/04/16 10:27

Prova a sostituire la prima macro di importazione dati (ci solo due semplici modifiche ma meglio evitare altre dimenticanze)
Codice: Seleziona tutto
Sub GetProsoccEu()
'
Cells.Clear    '<<<< riga aggiunta
Cells.NumberFormat = "@"   '<<<<<<<<<<<<<< riga aggiunta
myURL = "http://www.prosoccer.eu/football/"     '<<<<
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  'attesa addizionale
Do
    DoEvents
    If Timer > myStart + 2 Or Timer < myStart Then Exit Do
Loop

Set mycoll = IE.document.getelementbyid("thetable")
Set my2coll = mycoll.getelementsbytagname("span")

For Each myspan In my2coll
DoEvents
    If myspan.classname = "comp" Then I = I + 1: J = 0
    If Left(myspan.classname, 5) <> "" Then
        Cells(I, J + 1).Value = myspan.innertext
        J = J + 1
    End If
Next myspan
'Stop     'Vedi testo
'
'Chiusura IE
IE.Quit
Set IE = Nothing
Formatta   '<<<<  riga aggiunta
End Sub
Flash
Win10 + Office 2010 Ita
"Fotografica" al servizio dell'immagine
Avatar utente
Flash30005
Moderatore
 
Post: 8517
Iscritto il: 27/09/07 11:44
Località: Roma +o-

Re: Estarre dati da prosoccer.eu

Postdi apocrimata75 » 06/05/16 17:56

Un grazie come minimo è doveroso per l'aiuto e l'impegno profuso. Siete il numero 1.
Windows 7 - Office 2010
apocrimata75
Utente Senior
 
Post: 189
Iscritto il: 28/05/11 13:22


Torna a Applicazioni Office Windows


Topic correlati a "Estarre dati da prosoccer.eu":


Chi c’è in linea

Visitano il forum: Nessuno e 89 ospiti