Condividi:        

Importazione dati in excel da web

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

Importazione dati in excel da web

Postdi mlux81 » 18/10/17 09:15

Un pò di tempo fa Anthony mi ha aiutato con l'importazione tramite macro di alcuni dati da web in questa discussione viewtopic.php?f=26&t=108832 . Questa discussione si riferiva all’importazione di un solo link ora avrei bisogno di importare i dati contenuti in tutti i link di questa pagina web https://www.pcgs.com/auctionprices/cate ... dollar/744 creando per ogni link un foglio con i dati importati nella stessa cartella.

In ogni link potrebbero esserci poche decine/centinaia oppure migliaia di risultati. In ogni link c'è un menù a tendina in basso a sinistra dove ti fa scegliere il numero di righe da visualizzare tipo 50, 100, 500 o tutte (il link non varia al variare di tale scelta). Io avrei necessità di scaricare tutti i risultati per ogni singolo link mentre di default il link apre solo i primi 50 risultati e nell’importazione avrei necessità di mantenere la stessa formattazione per la colonna "SALE" (formato link in modo che nell'excel mi riporti anche il link cliccabile) e la colonna PRICE con la formattazione valuta dollaro USA.

Partendo dalla macro che mi aveva inviato Anthony nel post sopracitato ho provato semplicemente a modificare il link all'interno della macro ed il riferimento al foglio ma molto spesso ci sono altri problemi di duplicazione, tipo a volte scarica più volte i primi 50 risultati molte volte senza scaricare gli altri risultati, altre volte c'è un errore di debug che interrompe l’importazione dei dati tipo qui Paginate = CLng(Replace(myITM.getElementsByTagName("span")(1).innerText, "/", "", , , vbTextCompare)) oppure qui ActiveSheet.Hyperlinks.Add anchor:=Cells(I + 1, J + 1), _
Address:=tDtD.getElementsByTagName("a")(0).href
ma purtroppo non ho le conoscenze per poter correggere questi errori.

Spero di non chiedere troppo.
Grazie
mlux81
Utente Junior
 
Post: 24
Iscritto il: 06/09/17 10:48

Sponsor
 

Re: Importazione dati in excel da web

Postdi Anthony47 » 18/10/17 22:31

Sai gia' che e' solo un gioco di tempo e di pazienza, quindi devi aspettare che ci siano contemporaneamente ambedue questi ingredienti in sufficiente quantita'...

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

Re: Importazione dati in excel da web

Postdi mlux81 » 20/10/17 08:44

Ti ringrazio per la disponibilità.
Aspetterò senza problemi.
mlux81
Utente Junior
 
Post: 24
Iscritto il: 06/09/17 10:48

Re: Importazione dati in excel da web

Postdi mlux81 » 26/10/17 15:37

Riporto questo post in alto per far in modo che Anthony, quando avrà un pò di tempo libero, non si scordi di me.

Grazie
mlux81
Utente Junior
 
Post: 24
Iscritto il: 06/09/17 10:48

Re: Importazione dati in excel da web

Postdi Anthony47 » 02/11/17 00:35

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=0

Si 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/744

Terminata 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_2010

Il 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'...
Avatar utente
Anthony47
Moderatore
 
Post: 19196
Iscritto il: 21/03/06 16:03
Località: Ivrea

Re: Importazione dati in excel da web

Postdi mlux81 » 02/11/17 16:18

Ti ringrazio per la disponibilità ma purtroppo ho provato ad importare i dati e ci sono alcuni problemi che avevo già notato con la precedente macro e che avevo specificato nel primo post qui. Se provi ad importare i dati già nel primo link da importare https://www.pcgs.com/auctionprices/deta ... 7070/97073 ci sono errori di duplicazione nel senso che importa solo la prima pagina di 50 risultati x circa 130 volte tuttavia l'ho lasciato continuare ma arrivato al link
https://www.pcgs.com/auctionprices/deta ... 7070/97079 (rigo 7 di ZZZ2) l'importazione si interrompe per un problema di errore run time "424" necessario oggetto.

Non so se questi errori dipendono dalla mia versione di excel (2007) ma avevo già trovato su alcuni link questi stessi errori quando avevo cercato di importare manualmente i diversi link tramite la prima macro che mi avevi fatto.

Se è un problema di facile risoluzione ok altrimenti lascia perdere perchè non vorrei farti perdere altro tempo inutilmente.
mlux81
Utente Junior
 
Post: 24
Iscritto il: 06/09/17 10:48

Re: Importazione dati in excel da web

Postdi Anthony47 » 02/11/17 23:48

Probabilmente dipende dalla velocita' con cui IE avanza tra le pagine del documento... Comunque ho cambiato l'approccio con cui determino, all'interno della Sub AuctionCallerS2Sub di Modulo1, il completamento dell'avanzamento pagina. Le modifiche sono contenute nel blocco marcato *** MODIFICATA
Riporto il codice, anche se la sua comprensibilita' e' legata al sorgente html della pagina in esame, che viene aggiornato in modo dinamico da javascript:
Codice: Seleziona tutto
'altro codice
myURL = LURL
'
With LIE
    .navigate myURL
    .Visible = True
'Stop                '*** VEDI Testo
    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

hmTD = 50
'qui avanzo nelle pagine:
Do
    myStart = Timer  '*** MODIFICATA
    Set myITM = Nothing
    Do
        DoEvents
        If Timer > myStart + 25 Or Timer < myStart Then Exit Do         'timeout 25 sec
'        Set myITM = LIE.document.getElementsByTagName("TD")
reMyItm:
        Set myITM = Nothing: myWait (0.2)
        On Error Resume Next
            Set myITM = LIE.document.getElementById("auction-detail_info")
        On Error GoTo 0
        If Timer > myStart + 25 Or Timer < myStart Then Exit Do
        If myITM Is Nothing Then GoTo reMyItm       
'
        If myITM.innerText <> myShow Then            'Confronta la legenda corrente con la precedente; avanza se mutata
            myWait (0.2)
            myShow = myITM.innerText
            Debug.Print ">>   ", myShow
            Exit Do
        End If
        Debug.Print myITM.innerText
'    Set myITM = LIE.document.getElementsByTagName("TD")
        myWait (0.2)
   
'        If myITM.Length >= (hmTD - 2) Then Exit Do
    Loop
'dati probabilmente pronti
'etc etc


Per mia convenienza ho inoltre aggiunto una Sub myWait che utilizzo per le varie attese.

Il file scaricabile al link gia' pubblicato e' aggiornato con questa nuova versione di macro

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

Re: Importazione dati in excel da web

Postdi mlux81 » 03/11/17 10:17

Grazie

Provo e ti faccio sapere.
mlux81
Utente Junior
 
Post: 24
Iscritto il: 06/09/17 10:48

Re: Importazione dati in excel da web

Postdi mlux81 » 04/11/17 09:39

Grazie mille. Funziona perfettamente.

Ho lanciato l'importazione ieri sera verso le 23 e poco fa ha finito di importare tutto.
mlux81
Utente Junior
 
Post: 24
Iscritto il: 06/09/17 10:48

Re: Importazione dati in excel da web

Postdi mlux81 » 12/11/17 16:43

Ciao Anthony,
grazie alla tua macro sono riuscito a scaricare tutte le tabelle presenti sul sito https://www.pcgs.com/auctionPrices/cate ... 8-1921/744 ed il risultato finale è un file excel di 45MB circa, ottenuto dopo circa 24 ore di importazione tramite la tua macro.

Ora vorrei cercare, con il tuo aiuto, di automatizzare le mie ricerche ed avrei necessità

1. di aggiornare periodicamente (per esempio 1 volta a settimana) il file excel di 45mb solo con gli ultimi risultati. Visto che nel file di 45mb i risultati della ricerca sono aggiornati al 03/11/2017 è inutile lanciare ogni volta la macro che importa nuovamente tutti i dati pregressi che impiega tanto tempo e risorse. Quindi partendo dal file già esistente vorrei importare i nuovi risultati non presenti nel file excel, che di default sul sito, per ogni link, li ordina per data decrescente quindi si trovano generalmente nella prima pagina di 50 risultati;

p.s. mi ero scordato di chiederti nella precedente macro di fare in modo che la colonna d "price" fosse formattata come valuta usd $ invece la formatta come €. Nel file excel c'è un modo per cambiare la formattazione di una stessa colonna per tutti i fogli presenti, visto che son circa 170 fogli??

2. partendo dal secondo file excel allegato con l'elenco di alcune varietà contraddistinte da PCGS # (prima colonna), creare nello stesso file un foglio per ogni PCGS # nominato con il testo contenuto nelle colonne b-c-d in cui, attraverso una macro, viene incollato il risultato di un cerca e copia dello stesso PCGS # nel file di 45mb. Quest'ultima operazione incollla dovrebbe incollare tutte le colonne escluse solo le colonne A (di riempimento) / B (PCGS #).

files allegati:
1. http://www.filedropper.com/prezzidefinitivo03112017 file di 45mb

2. http://www.filedropper.com/elencovamvarieties_1 elenco varietà

Spero di essere stato abbastanza chiaro e spero che tu possa trovare un pò di tempo e pazienza per aiutarmi a completare questa operazione di ricerca che purtroppo manualmente sarebbe stata quasi impossibile.

Grazie
mlux81
Utente Junior
 
Post: 24
Iscritto il: 06/09/17 10:48

Re: Importazione dati in excel da web

Postdi Anthony47 » 13/11/17 19:05

Sai che bisogna aspettare la prossima ricarica...
Avatar utente
Anthony47
Moderatore
 
Post: 19196
Iscritto il: 21/03/06 16:03
Località: Ivrea

Re: Importazione dati in excel da web

Postdi mlux81 » 15/11/17 17:22

Certo che so che devo aspettare :) :) :)
mlux81
Utente Junior
 
Post: 24
Iscritto il: 06/09/17 10:48

Re: Importazione dati in excel da web

Postdi mlux81 » 23/11/17 12:38

riporto in alto questa discussione sperando che Anthony non si scordi di me.

Grazie
mlux81
Utente Junior
 
Post: 24
Iscritto il: 06/09/17 10:48

Re: Importazione dati in excel da web

Postdi mlux81 » 08/12/17 11:56

Rimetto i link dei files in quanto quello precedente è scaduto sperando che Anthony possa darci uno sguardo.
Grazie

http://www.filedropper.com/prezzidefinitivo03112017 file di 45 mb

http://www.filedropper.com/elencovamvarieties elenco varietà
mlux81
Utente Junior
 
Post: 24
Iscritto il: 06/09/17 10:48

Re: Importazione dati in excel da web

Postdi Anthony47 » 08/12/17 17:54

Purtroppo il file l'avevo gia' scaricato, non e' quello l'ostacolo :D . Resisti con quel che hai, vedrai che prima o poi...
Avatar utente
Anthony47
Moderatore
 
Post: 19196
Iscritto il: 21/03/06 16:03
Località: Ivrea

Re: Importazione dati in excel da web

Postdi mlux81 » 09/12/17 11:09

Grazie Anthony,
pensavo non avessi scaricato i file nel post precedente.
Io resisto senza problemi e spero tu riuscirai a risolvere il mio problema.
mlux81
Utente Junior
 
Post: 24
Iscritto il: 06/09/17 10:48

Re: Importazione dati in excel da web

Postdi mlux81 » 09/01/18 00:51

Ciao Anthony hai avuto modo di verificare le mie richieste di cui al primo post?
Grazie
mlux81
Utente Junior
 
Post: 24
Iscritto il: 06/09/17 10:48

Re: Importazione dati in excel da web

Postdi Anthony47 » 10/01/18 02:27

Purtroppo "Non ancora"
Come detto, questi giochi richiedono solo tempo e pazienza, non mi lasciano nessuna nuova conoscenza, per cui lo stimolo a lavorarci e' minimo.
Cio' detto non escludo che...

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

Re: Importazione dati in excel da web

Postdi mlux81 » 10/01/18 10:56

Ti ringrazio ugualmente per la disponibilità e se non puoi, non c'è problema, ci mancherebbe altro.
Mi hai già aiutato tantissimo con l'importazione originaria.

Grazie
mlux81
Utente Junior
 
Post: 24
Iscritto il: 06/09/17 10:48

Re: Importazione dati in excel da web

Postdi Anthony47 » 14/01/18 23:02

Come detto, "non escludevo che..."
Infatti, intaccando notevolmente le mie riserve di pazienza (il tempo e' da sempre in riserva) ho elaborato una nuova versione di file che dovrebbe lavorare anche in modo "incrementale", scaricabile qui:
https://www.dropbox.com/s/07k9wd3qw886p ... .xlsm?dl=0

Il file contiene 2 fogli basilari (Zzz2 e Log), e tanti fogli quanti sono i codici che vengono importati nel primo ciclo dalla pagina https://www.pcgs.com/auctionprices/cate ... dollar/744

Nei passaggi successivi al primo, il codice recupera le righe gia' presenti, eliminando solamente quelle del mese piu' recente; le nuove importazioni partono quindi da quanto gia' importato.

Il mio collaudo non e' stato intenso, ma mi pare che il risultato sia corretto.

Rispetto al file che hai gia' popolato, devi sostituire integralmente il codice di Modulo1 e di Modulo2; ragionevolmente devi anche sostituire la macro associata al pulsante sul foglio Zzz2, che ora deve essere AuctionCaller22Incr

Per i posteri allego il codice complessivo.
Su Modulo1:
Codice: Seleziona tutto
Option Explicit

Sub AuctionCallerS2SubIncr(LIE As Object, LURL As String, Optional olDate As Date = 0)
'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 mySp, my2, myShow As String
Dim myHArr(1 To 20), MaI As Long, lastB As Long

'
myURL = LURL
'
If olDate = 0 Then olDate = DateSerial(1901, 1, 1)
If olDate > DateSerial(1901, 12, 12) Then
    MaI = 1000
    Rows(1).Resize(1001).Insert Shift:=xlDown
Else
    MaI = 55555
End If
With LIE
    .navigate myURL
    .Visible = True
'Stop                '*** VEDI Testo
    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

hmTD = 50

Do
    myStart = Timer  '*** MODIFICATA
    Set myITM = Nothing
    Do
        DoEvents
        If Timer > myStart + 25 Or Timer < myStart Then Exit Do         'timeout 25 sec
'        Set myITM = LIE.document.getElementsByTagName("TD")
reMyItm:
        Set myITM = Nothing: myWait (0.2)
        On Error Resume Next
            Set myITM = LIE.document.getElementById("auction-detail_info")
        On Error GoTo 0
        If Timer > myStart + 25 Or Timer < myStart Then Exit Do
        If myITM Is Nothing Then GoTo reMyItm
'
        If myITM.innerText <> myShow Then
            myWait (0.2)
            myShow = myITM.innerText
            Debug.Print ">>   ", myShow
            Exit Do
        End If
        Debug.Print myITM.innerText
'    Set myITM = LIE.document.getElementsByTagName("TD")
        myWait (0.2)
   
'        If myITM.Length >= (hmTD - 2) Then Exit Do
    Loop
'dati probabilmente pronti
    Set myITM = LIE.document.getElementsByTagName("TABLE")(1)
        Cells(I + 1, 1) = "Table# " & tI + 1
        tI = tI + 1: I = I + 1
       
        For Each tRtR In myITM.Rows
        If I >= MaI Then
            Rows(I).Resize(1001).Insert Shift:=xlDown
            MaI = MaI + 1000
        End If
            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
            If IsDate(Cells(I, "C")) Then
                If CDate(Cells(I, "C")) <= olDate Then
                    Rows(I).ClearContents
                    GoTo finA       'esci per fine "nuovi dati"
                End If
            End If
       
        Next tRtR
    I = I + 1
'    Next myITM
    Set myITM = LIE.document.getElementById("auction-detail_length")
    hmTD = CLng(myITM.getElementsByTagName("select")(0).Value)
   
    Set myITM = LIE.document.getElementById("auction-detail_paginate")
    Set mySp = myITM.getElementsByTagName("span")
    If mySp.Length < 2 Then Exit Do
        Paginate = CLng(Replace(myITM.getElementsByTagName("span")(1).innerText, "/", "", , , vbTextCompare))
        cPag = CLng(myITM.getElementsByTagName("select")(0).Value)
        If cPag < Paginate Then
            LIE.document.getElementById("auction-detail_next").Click
            'Debug.Print Timer
            Do While LIE.Busy: DoEvents: Loop    'Attesa not busy
            Do While LIE.readyState <> 4: DoEvents: Loop 'Attesa documento
            'Debug.Print Timer
    '
            myWait (1)
        Else
            Exit Do
        End If
DoEvents
Loop
finA:
lastB = Cells(I, "B").End(xlDown).Row
If lastB < (Rows.Count - 10) Then
    Range(Cells(I + 1, 1), Cells(lastB - 1, 20)).EntireRow.Delete xlUp
End If

'Set myITM = Nothing
'IE.Quit
'Set IE = Nothing
Sheets("Log").Cells(Rows.Count, 1).End(xlUp).Offset(0, 1) = "Completata importazione da " & LURL
Sheets("Log").Cells(Rows.Count, 1).End(xlUp).Offset(0, 2) = I

End Sub

Sub myWait(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


Su Modolo2:
Codice: Seleziona tutto
Option Explicit
Dim IE As Object

Sub AuctionCaller22Incr()
'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
Dim NwSh As Boolean, lDate As Date, KI As Long, lastB As Long
'
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"
'
Sheets("Log").Cells(Rows.Count, 1).End(xlUp).Offset(2, 0) = Format(Now, "yyyy-mmm-dd") & ", Avviata importazione dati"
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
'Creato elenco su Zzz2
'Scan elenco e importazione subordinati:
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
                lastB = Cells(Rows.Count, "B").End(xlUp).Row
                Sheets("Log").Cells(Rows.Count, 1).End(xlUp).Offset(1, 0) = _
                   "Gia' esistente: " & ckShName(cCV)
                NwSh = False
                'Elimina la data piu' recente:
                lDate = Application.WorksheetFunction.Max(Range("C1:C1000"))
                For KI = 3 To 1000
                    If Cells(KI, "C") <> "" Or KI > lastB Then
                        If IsDate(Cells(KI, "C")) Then
                            If Cells(KI, "C") <> lDate Then
                                Range(Cells(3, 1), Cells(KI - 1, 20)).Delete xlShiftUp
                                lDate = Application.WorksheetFunction.Max(Range("C1:C1000"))
                                Exit For
                            End If
                        End If
                    End If
                Next KI
               
            Else
            '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)
                NwSh = True
                lDate = DateSerial(1901, 1, 1)
            End If
           
            Call AuctionCallerS2SubIncr(IE, .Cells(I, 1).Hyperlinks(1).Address, lDate)
        End If
    Next I
End With
'
Set myITM = Nothing
IE.Quit
Set IE = Nothing

MsgBox ("Completata importazione...")
End Sub

Sub NavigaTo(LURL As String)
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


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


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

Prossimo

Torna a Applicazioni Office Windows


Topic correlati a "Importazione dati in excel da web":


Chi c’è in linea

Visitano il forum: Nessuno e 138 ospiti