Ho esaurito tutto il budget mensile di tempo e di pazienza e ho rivisto il file precedentemente sviluppato perche' possa rispondere "teoricamente" a quanto io ho colto della tua richiesta.
Il nuovo file e' scaricabile qui:
https://www.dropbox.com/s/h99nqi40vy02d ... .xlsm?dl=0Si parte dal foglio Zzz2, su cui e' presente un pulsante che avvia la routine principale di importazione, la Sub AuctionCaller22 presente su Modulo2.
Questa importa sul foglio Zzz2 l'elenco disponibile sulla pagina di partenza,
http://www.pcgs.com/auctionprices/categ ... dollar/744Terminata l'importazione, per ogni voce presente in colonna A si apre il suo link e si importa in un nuovo foglio il tabellone o tabellino sottinteso al link (migliaia, centinaia o decine di righe)
Questa attivita' e' gestita da una variante della macro usata nel precedente lavoro, la Sub AuctionCallerS2Sub presente in Modulo1.
Le attivita' principali sono elencate nel foglio "Log" (aggiunta dei fogli, cancellazione di fogli con lo stesso nome, importazione da hyperlink).
Ho detto che "teoricamente" potrebbe rispondere, ma "praticamente" non so.
Non so infatti se il risultato totale potra' essere contenuto entro i limiti di excel (in primis numero di fogli e numero di hyperlink).
Puoi vedere questi limiti qui:
https://support.office.com/it-it/articl ... Excel_2010Il codice della nuova Sub AuctionCaller22:
- Codice: Seleziona tutto
Dim IE As Object
Sub AuctionCaller22()
'Vedi http://www.pc-facile.com/forum/viewtopic.php?f=26&t=108832
'Vedi http://www.pc-facile.com/forum/viewtopic.php?f=26&t=108964
Dim myURL As String, myITM As Object, tRtR, tDtD
Dim I As Long, myStart As Single, hmTD As Long, tI As Long, J As Long
Dim Paginate As Long, cPag As Long, hhLink As Hyperlink
Dim Tbls, kZ As Long, cSh As String, cCV As String
'
cSh = "Zzz2" '<<< Il foglio di partenza
'
On Error Resume Next
Sheets(cSh).Select
On Error GoTo 0
If ActiveSheet.Name <> cSh Then
MsgBox ("Il foglio di Partenza (" & cSh & ") non esiste, il processo viene pertanto abortito")
Exit Sub
End If
'
myURL = "https://www.pcgs.com/auctionprices/category/morgan-dollar/744"
'
Cells.ClearContents
Cells.Style = "Normal"
For Each hhLink In ActiveSheet.Hyperlinks
hhLink.Delete
Next hhLink
Call NavigaTo(myURL)
'dati probabilmente pronti
Set Tbls = IE.document.getElementsByTagName("TABLE")
For kZ = 0 To Tbls.Length - 1
Set myITM = IE.document.getElementsByTagName("TABLE")(kZ)
If myITM.className = "table table-striped auction-cat-table table-transform-create table-transform-thin" Then
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
Cells(I + 1, J + 1) = tDtD.innerText
If InStr(1, tDtD.innerHTML, "href", vbTextCompare) > 0 Then
DoEvents: DoEvents
' myURL = tDtD.getElementsByTagName("a")(0).href
ActiveSheet.Hyperlinks.Add anchor:=Cells(I + 1, J + 1), _
Address:=tDtD.getElementsByTagName("a")(0).href
End If
J = J + 1
Next tDtD
I = I + 1: J = 0
DoEvents
Cells(I, 1).Select
Next tRtR
I = I + 1
End If
Next kZ
With Sheets(cSh)
For I = 1 To .Cells(.Rows.Count, 1).End(xlUp).Row
If .Cells(I, 1).Hyperlinks.Count > 0 Then
cCV = .Cells(I, 1).Value
If Application.WorksheetFunction.CountIf(.Range(.Cells(1, 1), .Cells(I, 1)), cCV) > 1 Then
cCV = Application.WorksheetFunction.CountIf(.Range(.Cells(1, 1), .Cells(I, 1)), cCV) & "_" & cCV
End If
On Error Resume Next
Sheets(ckShName(cCV)).Select
On Error GoTo 0
If ActiveSheet.Name = ckShName(cCV) Then
Application.DisplayAlerts = False
ActiveSheet.Delete
Application.DisplayAlerts = True
Sheets("Log").Cells(Rows.Count, 1).End(xlUp).Offset(1, 0) = _
"Cancellato foglio esistente: " & ckShName(cCV)
End If
'inserire nuovo foglio
Worksheets.Add after:=Sheets(Sheets.Count)
ActiveSheet.Name = ckShName(cCV)
Sheets("Log").Cells(Rows.Count, 1).End(xlUp).Offset(1, 0) = _
"Aggiunto foglio: " & ckShName(cCV)
Sheets("Log").Cells(Rows.Count, 1).End(xlUp).Offset(1, 0) = _
.Cells(I, 1).Value
Call AuctionCallerS2Sub(IE, .Cells(I, 1).Hyperlinks(1).Address)
End If
Next I
End With
'
Set myITM = Nothing
IE.Quit
Set IE = Nothing
MsgBox ("Completata importazione...")
End Sub
Essa per comodita' si appoggia su due subroutine, sempre presenti in Modulo2:
- Codice: Seleziona tutto
Sub NavigaTo(LURL As String)
'Naviga a url e attende Document
Dim myTim As Single
'
If IE Is Nothing Then Set IE = CreateObject("InternetExplorer.Application")
myTim = Timer
With IE
.navigate LURL
.Visible = True
Do While .Busy:
DoEvents: If Timer > (myTim + 10) Then Exit Do
If Timer < myTim And Timer > 10 Then Exit Do
Loop 'Attesa not busy
Do While .readyState <> 4:
DoEvents: If Timer > (myTim + 20) Then Exit Do
If Timer < myTim And Timer > 20 Then Exit Do
Loop 'Attesa documento
End With
'
Dim cccc
Set cccc = IE.document.getElementsByTagName("TD")
Debug.Print cccc.Length
myTim = Timer 'attesa addizionale
Do
DoEvents
If Timer > myTim + 1 Or Timer < myTim Then Exit Do
Loop
End Sub
- Codice: Seleziona tutto
Function ckShName(pShN As String) As String
'Normalizza il Nome del foglio di lavoro
Dim noBB, wShN As String, piPPo
noBB = Array("/", "\", "*", "[", "]", "?", ":", "'")
'
wShN = pShN
For Each piPPo In noBB
wShN = Replace(wShN, piPPo, "_", , , vbTextCompare)
Next piPPo
ckShName = Left(wShN, 31)
End Function
Spero sia di qualche utilita'...