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