Condividi:        

prelevare con excel

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

prelevare con excel

Postdi maxrub » 20/06/14 20:51

Salve, ho creato un software che preleva dati da pagine simili a questa:

http://www.betonews.com/popup.asp?tp=21 ... idm=490521

con questo codice:

Codice: Seleziona tutto
    With ActiveSheet.QueryTables.Add(Connection:= _
        "URL;http://www.betonews.com/popup.asp?tp=2110&lang=en&idm=http://www.betonews.com/popup.asp?tp=2110&lang=en&idm=490521"  _
        , Destination:=Range("A1"))
        .Name = "results"
        .FieldNames = True
        .RowNumbers = False
        .FillAdjacentFormulas = False
        .PreserveFormatting = True
        .RefreshOnFileOpen = False
        .BackgroundQuery = True
        .RefreshStyle = xlInsertDeleteCells
        .SavePassword = False
        .SaveData = True
        .AdjustColumnWidth = True
        .RefreshPeriod = 0
        .WebSelectionType = xlEntirePage
        .WebFormatting = xlWebFormattingNone
        .WebPreFormattedTextToColumns = True
        .WebConsecutiveDelimitersAsOne = True
        .WebSingleBlockTextImport = False
        .WebDisableDateRecognition = False
        .WebDisableRedirections = False
        .Refresh BackgroundQuery:=False
    End With


però spesso capita che si blocca (oltre ad essere lento nel download). Quale può essere il problema e la soluzione?

Grazie
maxrub
Utente Junior
 
Post: 31
Iscritto il: 27/12/13 14:38

Sponsor
 

Re: prelevare con excel

Postdi Flash30005 » 21/06/14 01:55

Usando il link che hai postato si ottiene questa macro che importa la tabella senza problemi
Codice: Seleziona tutto
Sub ImpWeb()

    With ActiveSheet.QueryTables.Add(Connection:= _
        "URL;http://www.betonews.com/popup.asp?tp=2110&lang=en&idm=490521", _
        Destination:=Range("A1"))
        .Name = "popup.asp?tp=2110&lang=en&idm=490521_1"
        .FieldNames = True
        .RowNumbers = False
        .FillAdjacentFormulas = False
        .PreserveFormatting = True
        .RefreshOnFileOpen = False
        .BackgroundQuery = True
        .RefreshStyle = xlInsertDeleteCells
        .SavePassword = False
        .SaveData = True
        .AdjustColumnWidth = True
        .RefreshPeriod = 0
        .WebSelectionType = xlEntirePage
        .WebFormatting = xlWebFormattingNone
        .WebPreFormattedTextToColumns = True
        .WebConsecutiveDelimitersAsOne = True
        .WebSingleBlockTextImport = False
        .WebDisableDateRecognition = False
        .WebDisableRedirections = False
        .Refresh BackgroundQuery:=False
    End With
End Sub


Mentre il link che è nella tua macro è errato e va in errore
molto probabilmente cambiano gli indirizzi della pagina e quindi diventano obsoleti

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: prelevare con excel

Postdi maxrub » 21/06/14 07:01

Avevo sbagliato io a scrivere la macro di esempio, copio ed incollo la macro che mi dà il problema (in questa c'è una variabile pgweb in cui, all'interno di un ciclo, viene caricato il numero della pagina da scaricare, un numero composto da quattro cifre, come il 490521 della macro di esempio):

Codice: Seleziona tutto
    With ActiveSheet.QueryTables.Add(Connection:= _
        "URL;http://www.betonews.com/popup.asp?tp=2110&lang=en&idm=" & pgweb _
        , Destination:=Range("A1"))
        On Error GoTo NN8
        .Name = "results"
        .FieldNames = True
        .RowNumbers = False
        .FillAdjacentFormulas = False
        .PreserveFormatting = True
        .RefreshOnFileOpen = False
        .BackgroundQuery = True
        .RefreshStyle = xlInsertDeleteCells
        .SavePassword = False
        .SaveData = True
        .AdjustColumnWidth = True
        .RefreshPeriod = 0
        .WebSelectionType = xlEntirePage
        .WebFormatting = xlWebFormattingNone
        .WebPreFormattedTextToColumns = True
        .WebConsecutiveDelimitersAsOne = True
        .WebSingleBlockTextImport = False
        .WebDisableDateRecognition = False
        .WebDisableRedirections = False
        .Refresh BackgroundQuery:=False
    End With


comunque questa macro mi dà il problema che, all'interno del ciclo, ad un certo punto (non sempre lo stesso) và in blocco.
maxrub
Utente Junior
 
Post: 31
Iscritto il: 27/12/13 14:38

Re: prelevare con excel

Postdi Anthony47 » 21/06/14 15:31

La lettura dei dati da www.betonews.com/ era stata trattata gia' in questa discussione: viewtopic.php?p=568503#p566667
Era stata risolta con una macro pubblicata da me e un' altra pubblicata da Gigi_

Ai tempi di quel quesito lo scarico dal sito durava tantissimo; oggi tutta la macro si esegue in pochi secondi.

La macro importa le tabelle presenti sul sito nel foglio "prelievo" (che deve gia' esistere e sara' resettato senza preavviso all' avvio della macro).
Parti da quella macro e vedi se riesci ad adattarla.

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

Re: prelevare con excel

Postdi maxrub » 21/06/14 17:02

Anthony47 ha scritto:La lettura dei dati da http://www.betonews.com/ era stata trattata gia' in questa discussione: viewtopic.php?p=568503#p566667
Era stata risolta con una macro pubblicata da me e un' altra pubblicata da Gigi_

Ai tempi di quel quesito lo scarico dal sito durava tantissimo; oggi tutta la macro si esegue in pochi secondi.

La macro importa le tabelle presenti sul sito nel foglio "prelievo" (che deve gia' esistere e sara' resettato senza preavviso all' avvio della macro).
Parti da quella macro e vedi se riesci ad adattarla.

Ciao


Grazie, ma si tratta di fogli di download in html parse?

Ho letto la discussione e, sembra il foglio più veloce sia quello di Gigi_, allora l'ho scaricato, inseriti il numero di righe in A1 del Foglio2 e qualche numero relativo le righe da scaricare nella colonna B, ma la procedura si blocca con un errore di run time '5': Chiamata di routine o argomento non validi sull'istruzione:

Codice: Seleziona tutto
ck(3, link) = InStr(ck(2, link), a, p(data, 3)) + p(data, 5)
maxrub
Utente Junior
 
Post: 31
Iscritto il: 27/12/13 14:38

Re: prelevare con excel

Postdi Anthony47 » 21/06/14 17:40

Hai provato anche la mia macro?

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

Re: prelevare con excel

Postdi maxrub » 21/06/14 17:55

Provata ora: ottima e veloce! in un caso però si è bloccata, il foglio di internet explorer aperto aveva solo le grafiche di pagina iniziali visualizzate, la parte con il grafico con i dati invece non era stata scaricata. La macro era bloccata in attesa del caricamento dati, evidentemente per il fatt oche la pagina non era stata caricata completamente. Ho fermato la macro e riavviata e la pagina è stata scaricata. Siccome, nella versione definitiva, il mio foglio dovrà scaricare ed assemblare conseguenzialmente più di queste pagine, è possibile inserire nella macro una istruzione che, nel caso il download pagina sia fermio per più di 45 secondi la pagina venga di nuovo caricata? ecco la tua macro inserita nel foglio excel con cui la sto testando:

http://wikisend.com/download/319558/macro Anthony.xlsm
maxrub
Utente Junior
 
Post: 31
Iscritto il: 27/12/13 14:38

Re: prelevare con excel

Postdi maxrub » 21/06/14 19:16

ho provato ora un ciclo di 30 giorni consecutivi senza blocchi, sembra che ora funziona. Se si ripresenterà vedremo magari quell'altro problema. Mi occorrerebbe però una aggiunta al download: mi serve importare nel foglio excel anche il link dei collegamenti che si trovano su ogni singola riga, in fondo, all'ultima colonna cliccando sulla "H"
maxrub
Utente Junior
 
Post: 31
Iscritto il: 27/12/13 14:38

Re: prelevare con excel

Postdi maxrub » 21/06/14 19:45

mi si è bloccato di nuovo durante un'altra prova, in pratica internet explorer rimane in questa condizione:

Immagine

ed il foglio non carica la pagina rimanendo lì fermo all'infinito
maxrub
Utente Junior
 
Post: 31
Iscritto il: 27/12/13 14:38

Re: prelevare con excel

Postdi raimea » 21/06/14 21:04

ciao
prova questo, e' quello di cui si riferiva antony
preleva da beton e uso i.e.

ciao

https://db.tt/XUGB9rDL
S.O. win10, Excell 2019
Avatar utente
raimea
Utente Senior
 
Post: 1410
Iscritto il: 11/02/10 07:33
Località: lago

Re: prelevare con excel

Postdi maxrub » 21/06/14 22:09

Grazie, ma devo cliccare su "sito"? se è così mi si blocca dandomi un errore di compilazione "impossibile trovare il progetto o la libreria"
maxrub
Utente Junior
 
Post: 31
Iscritto il: 27/12/13 14:38

Re: prelevare con excel

Postdi Anthony47 » 22/06/14 02:28

Ho modificato la macro precedente, utilizzando la funzione ieWaitPage (sviluppata per altri casi) che consente di gestire il timeout sulla pagina web, e quindi l' eventuale retry.
Inoltre ho inserito la cattura dei due hyperlink associati all' ultima colonna della tabella.
In nuovo codice e' il seguente, e sostituisce in toto quello indicato nella discussione che ti avevo linkato:
Codice: Seleziona tutto
Sub GetTabRaim22()
Dim BetFlag As Boolean, myColl, my2Coll, IE As Object, LnkCnt As Long
Dim myRetr As Long, I0 As Long, I As Long, myLink As Object
'
myUrl = "http://www.betonews.com/table.asp?tp=2001&lang=en&dd=20&dm=5&dy=2014&df=1&dw=3"
Set IE = CreateObject("InternetExplorer.Application")
'
Refr:
Worksheets("prelievo").Select
Range("A5").Resize(1000, 23).ClearContents
ActiveSheet.Hyperlinks.Delete
'
With IE
'Range("AA:AE").ClearContents
Debug.Print "---------"
    .navigate myUrl
    .Visible = True
End With
'wait for page...
myreS = ieWaitPage(IE, 0.5, 40)    'sessione, Stab Time, TimeOut time
If myreS <> 0 Then
    If myRetr < 5 Then
        myRetr = myRetr + 1
        GoTo Refr
    Else
        Rispo = MsgBox("3 errori sulla pagina; recuperare manualmente e poi:" _
            & vbCrLf & "-premere OK se recuperato" _
            & vbCrLf & "-premere CANCEL se non recuperabile e quindi Abort della raccolta", vbOKCancel)
        If Rispo <> vbOK Then GoTo AbortA
    End If
End If
myRetr = 0
'
'Leggi le tabelle
Worksheets("prelievo").Select
Range("A10").CurrentRegion.Clear
'Stop
DoEvents
I = 5
Set myColl = IE.document.getElementsByTagName("TABLE")
Set my2Coll = IE.document.getElementsByTagName("A")
'aaa = myColl.Length
For Each myItm In myColl
BetFlag = False
    For Each trtr In myItm.Rows
'[C2] = trtr.innertext: Call Macro1
    If Len(trtr.innertext) > Len(Replace(trtr.innertext, "Away Team", "")) And Len(trtr.innertext) < 10000 Then
        BetFlag = True
    End If
        For Each tdtd In trtr.Cells
        DoEvents
                If BetFlag Then
                    Cells(I + 1, j + 1) = tdtd.innertext
                    j = j + 1
                End If
        Next tdtd
        If BetFlag Then
            If j > 15 And I0 = 0 Then I0 = I + 1
            I = I + 1: j = 0
        End If
    Next trtr
If BetFlag Then I = I + 1
Next myItm
'posiziona i links:
If I0 > 0 Then
    For Each myLink In my2Coll
        If Len(myLink.href) > Len(Replace(myLink.href, "popup.asp", "")) Then
            ActiveSheet.Hyperlinks.Add Anchor:=Cells(I0, "V").Offset(Int(LnkCnt / 2), LnkCnt Mod 2), _
              Address:=myLink.href, _
              TextToDisplay:=myLink.href
            LnkCnt = LnkCnt + 1
        End If
    Next myLink
End If
'Cells(Rows.Count, "AF").End(xlUp).Offset(1, 0).Value = Timer

Stop     'Vedi testo

'GoTo Refr
AbortA:
'Chiusura IE
IE.Quit
Set IE = Nothing
Set myColl = Nothing
Set my2Coll = Nothing

End Sub

Sub myWait(ByVal myStab As Single)
Dim myStTim As Single
'
    myStTim = Timer
    Do          'wait myStab
        DoEvents
        If Timer > myStTim + myStab Or Timer < myStTim Then Exit Do
    Loop
End Sub


Function ieWaitPage(ByRef iEs As Object, ByVal myStab As Long, ByVal myTO As Long) As Long
'0=ok; 1=timeout su .Busy; 2=timeout su .ReadyState; 4=Altro errore
'
Dim myStTim As Single, FlErr As Long
'
On Error GoTo FatErr
myStTim = Timer
Call myWait(0.2)      'wait iniziale
'
With iEs
    Do While .Busy: DoEvents:
        If Timer > myStTim + myTO Or Timer < myTO Then FlErr = 1: Exit Do
        Loop    'Attesa not busy
    Do While .ReadyState <> 4: DoEvents
        If FlErr <> 0 Then Exit Do
        If Timer > myStTim + myTO Or Timer < myTO Then FlErr = FlErr + 2: Exit Do
        Loop 'Attesa documento
End With
If FlErr = 0 Then
aazzz = myStab

    Call myWait(myStab)
'    myStTim = Timer
'    Do          'wait myStab
'        DoEvents
'        If Timer > myStTim + myStab Or Timer < myStTim Then Exit Do
'    Loop
End If
    ieWaitPage = FlErr
Exit Function
FatErr:
    ieWaitPage = FlErr + 4
End Function


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

Re: prelevare con excel

Postdi maxrub » 22/06/14 07:24

Fantastico! ti ringrazio.

L'ho provato in un ciclo di prova e mi ha scaricato tutto Maggio senza problemi.

Ora, se volessi scaricare uno ad uno i fogli relativi agli indirizzi web dell'ultima colonna quale macro dovrei utilizzare? Nel vecchio foglio ne utilizzavo una simile a quella che ho postato ad inizio thread, ma mi dava i problemi esposti (blocchi e lentezza).
maxrub
Utente Junior
 
Post: 31
Iscritto il: 27/12/13 14:38

Re: prelevare con excel

Postdi Anthony47 » 22/06/14 10:36

Devi ispirarti alla macro che hai adesso, ma la parte centrale (dalla riga 'Leggi le tabelle a Stop deve essere rivista guardando al sorgente html delle nuove pagine.
Se si tratta di importare tutte la tabelle, puoi usare il codice rilasciato ad esempio qui: viewtopic.php?t=100428#p579927

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

Re: prelevare con excel

Postdi maxrub » 22/06/14 11:13

Ho utilizzato il codice che avevi postato nella discussione linkata, l'ultimo, quello che richiedeva l'attivazione di alcune librerie. E' velocissimo, apparentemente (non so se dipenda anche dai dati da scaricare) più veloce di quello precedente. Non sò se sia dovuto alle librerie html utilizzate, se così fosse non sarebbe possibile utilizzarle anche per il download delle altre pagine di cui parlavamo prima?
maxrub
Utente Junior
 
Post: 31
Iscritto il: 27/12/13 14:38

Re: prelevare con excel

Postdi maxrub » 22/06/14 16:46

Ho visto che il promo codice và a compilare la tabella con tutti i dati una cella alla volta e questo a volte, con tabelle molto popolate, rende il processo lento. E' possibile fargli operare un unico copia/incolla di tutta la tabella anzichè di ogni singola cella alla volta?
maxrub
Utente Junior
 
Post: 31
Iscritto il: 27/12/13 14:38

Re: prelevare con excel

Postdi maxrub » 23/06/14 13:33

Provato questa mattina su un altro pc ha scaricato velocemente. Credo a questo punto si trattasse di un problema di lentezza temporaneo che avevo nel pc a casa.
maxrub
Utente Junior
 
Post: 31
Iscritto il: 27/12/13 14:38

Re: prelevare con excel

Postdi newtek » 01/07/14 20:39

Anthony47 ha scritto:Ho modificato la macro precedente, utilizzando la funzione ieWaitPage (sviluppata per altri casi) che consente di gestire il timeout sulla pagina web, e quindi l' eventuale retry.
Inoltre ho inserito la cattura dei due hyperlink associati all' ultima colonna della tabella.
In nuovo codice e' il seguente, e sostituisce in toto quello indicato nella discussione che ti avevo linkato:
Codice: Seleziona tutto
Sub GetTabRaim22()
Dim BetFlag As Boolean, myColl, my2Coll, IE As Object, LnkCnt As Long
Dim myRetr As Long, I0 As Long, I As Long, myLink As Object
'
myUrl = "http://www.betonews.com/table.asp?tp=2001&lang=en&dd=20&dm=5&dy=2014&df=1&dw=3"
Set IE = CreateObject("InternetExplorer.Application")
'
Refr:
Worksheets("prelievo").Select
Range("A5").Resize(1000, 23).ClearContents
ActiveSheet.Hyperlinks.Delete
'
With IE
'Range("AA:AE").ClearContents
Debug.Print "---------"
    .navigate myUrl
    .Visible = True
End With
'wait for page...
myreS = ieWaitPage(IE, 0.5, 40)    'sessione, Stab Time, TimeOut time
If myreS <> 0 Then
    If myRetr < 5 Then
        myRetr = myRetr + 1
        GoTo Refr
    Else
        Rispo = MsgBox("3 errori sulla pagina; recuperare manualmente e poi:" _
            & vbCrLf & "-premere OK se recuperato" _
            & vbCrLf & "-premere CANCEL se non recuperabile e quindi Abort della raccolta", vbOKCancel)
        If Rispo <> vbOK Then GoTo AbortA
    End If
End If
myRetr = 0
'
'Leggi le tabelle
Worksheets("prelievo").Select
Range("A10").CurrentRegion.Clear
'Stop
DoEvents
I = 5
Set myColl = IE.document.getElementsByTagName("TABLE")
Set my2Coll = IE.document.getElementsByTagName("A")
'aaa = myColl.Length
For Each myItm In myColl
BetFlag = False
    For Each trtr In myItm.Rows
'[C2] = trtr.innertext: Call Macro1
    If Len(trtr.innertext) > Len(Replace(trtr.innertext, "Away Team", "")) And Len(trtr.innertext) < 10000 Then
        BetFlag = True
    End If
        For Each tdtd In trtr.Cells
        DoEvents
                If BetFlag Then
                    Cells(I + 1, j + 1) = tdtd.innertext
                    j = j + 1
                End If
        Next tdtd
        If BetFlag Then
            If j > 15 And I0 = 0 Then I0 = I + 1
            I = I + 1: j = 0
        End If
    Next trtr
If BetFlag Then I = I + 1
Next myItm
'posiziona i links:
If I0 > 0 Then
    For Each myLink In my2Coll
        If Len(myLink.href) > Len(Replace(myLink.href, "popup.asp", "")) Then
            ActiveSheet.Hyperlinks.Add Anchor:=Cells(I0, "V").Offset(Int(LnkCnt / 2), LnkCnt Mod 2), _
              Address:=myLink.href, _
              TextToDisplay:=myLink.href
            LnkCnt = LnkCnt + 1
        End If
    Next myLink
End If
'Cells(Rows.Count, "AF").End(xlUp).Offset(1, 0).Value = Timer

Stop     'Vedi testo

'GoTo Refr
AbortA:
'Chiusura IE
IE.Quit
Set IE = Nothing
Set myColl = Nothing
Set my2Coll = Nothing

End Sub

Sub myWait(ByVal myStab As Single)
Dim myStTim As Single
'
    myStTim = Timer
    Do          'wait myStab
        DoEvents
        If Timer > myStTim + myStab Or Timer < myStTim Then Exit Do
    Loop
End Sub


Function ieWaitPage(ByRef iEs As Object, ByVal myStab As Long, ByVal myTO As Long) As Long
'0=ok; 1=timeout su .Busy; 2=timeout su .ReadyState; 4=Altro errore
'
Dim myStTim As Single, FlErr As Long
'
On Error GoTo FatErr
myStTim = Timer
Call myWait(0.2)      'wait iniziale
'
With iEs
    Do While .Busy: DoEvents:
        If Timer > myStTim + myTO Or Timer < myTO Then FlErr = 1: Exit Do
        Loop    'Attesa not busy
    Do While .ReadyState <> 4: DoEvents
        If FlErr <> 0 Then Exit Do
        If Timer > myStTim + myTO Or Timer < myTO Then FlErr = FlErr + 2: Exit Do
        Loop 'Attesa documento
End With
If FlErr = 0 Then
aazzz = myStab

    Call myWait(myStab)
'    myStTim = Timer
'    Do          'wait myStab
'        DoEvents
'        If Timer > myStTim + myStab Or Timer < myStTim Then Exit Do
'    Loop
End If
    ieWaitPage = FlErr
Exit Function
FatErr:
    ieWaitPage = FlErr + 4
End Function


Ciao

Ringrazio anticipatamente per l'attenzione e mi scuso per la mia ignoranza su vba.
Ho provato questa macro e funziona benissimo.
Volevo sapere se era possibile scaricare i link che copia nella celle v w in un altro foglio.
Mi spiego: nel foglio prelievo nella cella v10 ho questo link: http://www.betonews.com/popup.asp?tp=21 ... idm=537035 e nella cella w10 quest'altro: http://www.betonews.com/popup.asp?tp=21 ... idm=537035.
Scrivendo nel foglio1 in una cella (es. a3) 10 vorrei che in foglio2 e in foglio3 si andassero a copiare i dati dei link; se scrivo 11 va a copiare i link del successivo incontro e così via....
Grazie
newtek
Newbie
 
Post: 3
Iscritto il: 01/07/14 19:51

Re: prelevare con excel

Postdi Anthony47 » 02/07/14 01:42

Se vuoi importare su un foglio le tabelle disponibili a quei link puoi usare la macro illustrata qui: viewtopic.php?p=581022#p581076

Se vuoi poter scegliere quale riga importare scrivendone il valre in A3, allora potresti partire da una macro di WorksheetChange, del tipo
Codice: Seleziona tutto
Private Sub Worksheet_Change(ByVal Target As Range)
'
If Target.Address <> "$A$3" Then Exit Sub
Set IE = CreateObject("InternetExplorer.Application")
   
   
'il codice per leggere il primo link su Foglio2

'il codice ripetuto per leggere il secondo link su Foglio3


IEQuit:
'Chiusura IE
IE.Quit
Set IE = Nothing
End Sub

Il rimanente codice lo prendi dalla macro che ti ho linkato; devi ovviamente avere una unica " Set IE = CreateObject(etc etc" in testa e una unica "Chiusura IE in coda; come li ho posizionati sopra nella Worksheet_Change.
Inoltre devi modificare l' istruzione che compila myURL, in
Codice: Seleziona tutto
myURL=cells(target.value,"V").value   'primo link

myURL=cells(target.value,"W").value     'secondo link.


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

Re: prelevare con excel

Postdi newtek » 02/07/14 12:17

Codice: Seleziona tutto
Sub GetTabRaim22()
Dim BetFlag As Boolean, myColl, my2Coll, IE As Object, LnkCnt As Long
Dim myRetr As Long, I0 As Long, I As Long, myLink As Object
'
myDate = Int(Now())
myUrl = "http://www.betonews.com/table.asp?tp=2001&lang=en&dd=" & Day(myDate) _
    & "&dm=" & Month(myDate) & "&dy=" & Year(myDate) & "&df=1&dw=3"
Set IE = CreateObject("InternetExplorer.Application")
'
Refr:
Worksheets("prelievo").Select
Range("A5").Resize(1000, 23).ClearContents
ActiveSheet.Hyperlinks.Delete
'
With IE
'Range("AA:AE").ClearContents
Debug.Print "---------"
    .navigate myUrl
    .Visible = True
End With
'wait for page...
myreS = ieWaitPage(IE, 0.5, 40)    'sessione, Stab Time, TimeOut time
If myreS <> 0 Then
    If myRetr < 5 Then
        myRetr = myRetr + 1
        GoTo Refr
    Else
        Rispo = MsgBox("3 errori sulla pagina; recuperare manualmente e poi:" _
            & vbCrLf & "-premere OK se recuperato" _
            & vbCrLf & "-premere CANCEL se non recuperabile e quindi Abort della raccolta", vbOKCancel)
        If Rispo <> vbOK Then GoTo AbortA
    End If
End If
myRetr = 0
'
'Leggi le tabelle
Worksheets("prelievo").Select
Range("A10").CurrentRegion.Clear
'Stop
DoEvents
I = 5
Set myColl = IE.document.getElementsByTagName("TABLE")
Set my2Coll = IE.document.getElementsByTagName("A")
'aaa = myColl.Length
For Each myItm In myColl
BetFlag = False
    For Each trtr In myItm.Rows
'[C2] = trtr.innertext: Call Macro1
    If Len(trtr.innertext) > Len(Replace(trtr.innertext, "Away Team", "")) And Len(trtr.innertext) < 10000 Then
        BetFlag = True
    End If
        For Each tdtd In trtr.Cells
        DoEvents
                If BetFlag Then
                    Cells(I + 1, J + 1) = tdtd.innertext
                    J = J + 1
                End If
        Next tdtd
        If BetFlag Then
            If J > 15 And I0 = 0 Then I0 = I + 1
            I = I + 1: J = 0
        End If
    Next trtr
If BetFlag Then I = I + 1
Next myItm
'posiziona i links:
If I0 > 0 Then
    For Each myLink In my2Coll
        If Len(myLink.href) > Len(Replace(myLink.href, "popup.asp", "")) Then
            ActiveSheet.Hyperlinks.Add Anchor:=Cells(I0, "V").Offset(Int(LnkCnt / 2), LnkCnt Mod 2), _
              Address:=myLink.href, _
              TextToDisplay:=myLink.href
            LnkCnt = LnkCnt + 1
        End If
    Next myLink
End If
'Cells(Rows.Count, "AF").End(xlUp).Offset(1, 0).Value = Timer



'GoTo Refr
AbortA:
'Chiusura IE
IE.Quit
Set IE = Nothing
Set myColl = Nothing
Set my2Coll = Nothing

End Sub

Sub myWait(ByVal myStab As Single)
Dim myStTim As Single
'
    myStTim = Timer
    Do          'wait myStab
        DoEvents
        If Timer > myStTim + myStab Or Timer < myStTim Then Exit Do
    Loop
End Sub


Function ieWaitPage(ByRef iEs As Object, ByVal myStab As Long, ByVal myTO As Long) As Long
'0=ok; 1=timeout su .Busy; 2=timeout su .ReadyState; 4=Altro errore
'
Dim myStTim As Single, FlErr As Long
'
On Error GoTo FatErr
myStTim = Timer
Call myWait(0.2)      'wait iniziale
'
With iEs
    Do While .Busy: DoEvents:
        If Timer > myStTim + myTO Or Timer < myTO Then FlErr = 1: Exit Do
        Loop    'Attesa not busy
    Do While .readyState <> 4: DoEvents
        If FlErr <> 0 Then Exit Do
        If Timer > myStTim + myTO Or Timer < myTO Then FlErr = FlErr + 2: Exit Do
        Loop 'Attesa documento
End With
If FlErr = 0 Then
aazzz = myStab

    Call myWait(myStab)
'    myStTim = Timer
'    Do          'wait myStab
'        DoEvents
'        If Timer > myStTim + myStab Or Timer < myStTim Then Exit Do
'    Loop
End If
    ieWaitPage = FlErr
Exit Function
FatErr:
    ieWaitPage = FlErr + 4
End Function


Private Sub Worksheet_Change(ByVal Target As Range)
'
If Target.Address <> "$A$3" Then Exit Sub
Set IE = CreateObject("InternetExplorer.Application")
   
   
'il codice per leggere il primo link su Foglio2
myUrl = Cells(Target.Value, "V").Value 'primo link
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 + 1 Or Timer < myStart Then Exit Do
Loop
'Leggi le tabelle, su un nuovo foglio
Sheets("foglio2").Select     '<<< Vedi testo
Cells.Clear

Set myColl = IE.document.getElementsByTagName("TABLE")
If myColl.Length < 5 Then
    MsgBox ("Numero anomalo di tabelle, abortito")
    GoTo IEQuit
End If
With myColl(4)
    For Each trtr In .Rows
        For Each tdtd In trtr.Cells
            Cells(I + 1, J + 1) = tdtd.innertext
            Cells(I + 1, 1).Select
            J = J + 1
        Next tdtd
        I = I + 1: J = 0
    Next trtr
I = I + 2
'Next myItm
End With
'Next II
SendKeys "{F5}", True
        SendKeys "{ENTER}", True
'il codice ripetuto per leggere il secondo link su Foglio3
myUrl = Cells(Target.Value, "W").Value  'secondo link.
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 + 1 Or Timer < myStart Then Exit Do
Loop
'Leggi le tabelle, su un nuovo foglio
Sheets("foglio3").Select     '<<< Vedi testo
Cells.Clear

Set myColl = IE.document.getElementsByTagName("TABLE")
If myColl.Length < 5 Then
    MsgBox ("Numero anomalo di tabelle, abortito")
    GoTo IEQuit
End If
With myColl(4)
    For Each trtr In .Rows
        For Each tdtd In trtr.Cells
            Cells(I + 1, J + 1) = tdtd.innertext
            Cells(I + 1, 1).Select
            J = J + 1
        Next tdtd
        I = I + 1: J = 0
    Next trtr
I = I + 2
'Next myItm
End With
'Next II
SendKeys "{F5}", True
        SendKeys "{ENTER}", True

IEQuit:
'Chiusura IE
IE.Quit
Set IE = Nothing
End Sub





Come premesso con visual basic non ci capisco un cappero... Sicuramente ho saltato qualche passaggio...
Mettendo un numero nella cella a3 non mi dà errore (questo per me e' già un successo) ma non mi copia nemmeno i dati delle tabelle corrispondenti nel foglio2 e foglio3.
Grazie
newtek
Newbie
 
Post: 3
Iscritto il: 01/07/14 19:51

Prossimo

Torna a Applicazioni Office Windows


Topic correlati a "prelevare con excel":


Chi c’è in linea

Visitano il forum: Nessuno e 64 ospiti