› Sviluppare funzionalita su Microsoft Office con VBA › Importare dati in tabella excel da una pagina web
-
AutoreArticoli
-
Salve a tutti, da un po' di tempo sto costruendo il mio piccolo database di film con excel, e per vari motivi avevo pensato di velocizzare le operazioni di importazione con una macro dedicata, usando magari il VBA con tanto di Userform e Sub.
Per quanto riguarda Textbox e vari, riesco a districarmi discretamente, anche se non sono programmatore, qualche piccolo lavoretto riesco a farlo; ma importare dati da internet, mi mancava proprio.
Spulciando su vari siti online ho trovato una Sub che fa al caso mio, quindi l'ho adattata alle mie esigenze, e devo dire che funziona egregiamente, importando i dati di mio interesse in tabelle consecutive su un foglio: quello che manca è l'importazione anche del titolo della tabella, in quanto non trovo il modo di prelevarlo.
Una volta che ho i dati sul foglio, riesco tranquillamente a lavorarli con la Userform.
Questo è il codice che utilizzo:
Sub GetWebTab2() Dim IE As Object, F As Long Dim myRColl, myDColl, KK As Long, I As Long, J As Long, myColl, myR, myTD ' myURL = "https://www.imdb.com/title/tt0227445/fullcredits?ref_=tt_cl_sm#cast" 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 Application.Goto (Sheets("Foglio3").Range("A1")) Cells.Clear Set myColl = IE.Document.getElementsbyTagName("TABLE") For Each myItm In myColl Cells(I + 1, "A").Value = "TABELLA_" & KK: KK = KK + 1: I = I + 1 For Each trtr In myItm.Rows For Each tdtd In trtr.Cells Cells(I + 1, J + 1) = tdtd.innertext J = J + 1 Next tdtd I = I + 1: J = 0 Next trtr I = I + 2 Next myItm 'Legge le tabelle dentro gli iframe: Set myColl = IE.Document.getElementsbyTagName("iframe") For F = 0 To myColl.Length - 1 If Left(myColl(F).ID, 7) = "myframe" Then Set my2coll = myColl(F).contentDocument.getElementsbyTagName("table") For Each myItm In my2coll Cells(I + 1, "A").Value = "TABELLA_" & KK: KK = KK + 1: I = I + 1 Set myRColl = myItm.getElementsbyTagName("tr") For Each myR In myRColl Set myDColl = myR.getElementsbyTagName("td") For Each myTD In myDColl Cells(I + 1, J + 1) = myTD.innertext J = J + 1 Next myTD I = I + 1: J = 0 Next myR I = I + 2 Next myItm End If Next F ' Cells.WrapText = False Range("A1").Select ' IE.Quit Set IE = Nothing End Sub
Questa Sub mi importa i dati di mio interesse, ma divide il tutto in TABELLA_0, TABELLA_1, TABELLA_2, ecc.; io vorrei che al posto di quelle diciture ci fosse: "Directed by", "Writing Credits", "Cast", ecc., proprio come sulla pagina web di origine.
So' già che la parola TABELLA la genero con la macro, ed ho provato ad agire li, ma con le mie conoscenze proprio non ci arrivo: non so' bene come modificarlo per fargli prendere anche i "titoli" delle tabelle...
Spero qualcuno mi possa aiutare. Grazie
Ma se sai a priori che i titoli delle tabelle saranno sempre e soltanto quelli da te indicati, io direi che non ti conviene spulciare il sorgente della pagina html per cercare eventuali tags.
Io preparerei una mask string con i nomi dei titoli delle tabelle e poi preleverei il nome giusto attraverso il suo indice, definito da KK.
Option Explicit Const TITLES as String = "Directed by,Writing Credits,Cast,Produced by,Music by,...continua tu..." ...poi dentro il codice... KK = 0 For Each myItm In myColl Cells(I + 1, "A").Value = Split(TITLES, ",")(KK) KK = KK + 1 I = I + 1 For Each trtr In myItm.Rows
Purtroppo sono uguali sempre e solo le prime 3 tabelle (voci), dopo, a volte cambiano; ecco un esempio:
https://www.imdb.com/title/tt0064116/fullcredits/?ref_=tt_ov_st_sm
https://www.imdb.com/title/tt2096673/fullcredits/?ref_=tt_ov_st_sm
dopo il Cast, le voci di mio interesse sono sempre le stesse, ma non sempre nello stesso ordine e a volte ne manca qualcuna; queste quelle che mi interesserebbe prendere:
- Directed by (Regia)
- Writing Credits (Sceneggiatura)
- Cast
- Music by (Musiche)
- Cinematography by (Fotografia)
- Film Editing by (Montaggio)
- Production Companies (Produzione)
- Distributors (Distribuzione)
e si trovano in 2 diverse pagine:
https://www.imdb.com/title/tt2096673/fullcredits/?ref_=tt_ov_st_sm
https://www.imdb.com/title/tt2096673/companycredits?ref_=ttfc_sa_3
Purtroppo sono uguali sempre e solo le prime 3 tabelle (voci), dopo, a volte cambiano
Peccato davvero perchè questo complica a dismisura, per quello che vedo, conosco e so posso suggerire un approccio micidiale ma che in teoria può funzionare: leggere l'id "fullcredits_content" (che contiene tutto il contenuto della pagina che ti interessa), quindi scorrere in sequenza i diversi tag "h4 class" che dopo il meta "::before" contengono il testo visualizzato come titolino della singola sezione. Sto esaminando il sorgente con il Chrome inspector (strumenti per sviluppatori, Ctrl-Shift-I) e sinceramente non mi viene in mente niente di meglio.
Capisco quello che intendi.... speriamo che qualcuno abbia fatto qualcosa del genere e posso darmi una dritta. Intanto seguo la tua idea e vedo cosa riesco a costruire.
Grazie per il momento.
Dunque, stasera ho cercato di attuare la mia folle idea...
Set x = IE.Document.getElementbyID("fullcredits_content") v = Split(x.innerhtml, "<h4 class=""dataHeaderWithBorder"">")
Il primo Set assegna a x l'intero contenuto del corpo della pagina, quella che contiene tra le altre cose anche i titoli delle diverse sezioni che ti interessano.
La seconda assegnazione alla variabile "v" invece splitta il contenuto che abbiamo appena recuperato in corrispondenza dei marcatori html che identificano il titolino della sezione.
La cosa è al momento molto brutta e solo abbozzata, però leggendo in sequenza il risultato di ogni elmento in "v" e recuperando solo la prima linea (quella che termina con carriage return per capirci) dovrei esser ein grado di ottenere il testo desiderato. Che poi va ripulito un pochino... vabbè ma è un primo passo.
Se domani sono un attimo libero faccio una prova concreta.
By the way, nel tuo codice devi dichiarare le variabili, inserire Option Explicit e fare un'indentazione più coerente altrimenti è un guazzabuglio 🙂
Grazie vecchio frac, domani la provo anche si.
Si, il codice lo devo ripulire e non solo, dovrei anche commentarlo per bene... e di questo avrei bisogno aiuto, in quanto alcuni passaggi mi vengono difficili da capire. Purtroppo ho preso stralci qua e la su internet per arrivare ad abbozzare quello che ho postato.... e con la tua ultima dritta, credo che sia arrivato il tempo di sistemarlo davvero. Chiedo troppo in un aiuto anche in questo? Grazie, notte
Ti faccio una piccola proposta. Poi il codice si può anche commentare.
L'output è probabilmente da pulire, ma mi preme ottenere la tua approvazione prima di rifinire.
Option Explicit Private Declare Sub Sleep Lib "kernel32" (ByVal dwMilliseconds As Long) Sub GetWebTab2() Dim IE As Object Dim f As Long, myRColl As Variant, myDColl As Variant Dim kk As Long, i As Long, j As Long Dim myColl As Variant Dim my2Coll As Variant Dim myR As Variant, myTD As Variant Dim myItm As Variant Dim myURL As String Dim myStart As Single Dim content As Variant Dim v As Variant Dim trtr As Variant, tdtd As Variant Dim sections() As String Dim dataHeader As Variant, dataHeaders As Variant myURL = "https://www.imdb.com/title/tt0227445/fullcredits?ref_=tt_cl_sm#cast" 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 Set content = IE.Document.getElementbyID("fullcredits_content") dataHeaders = Split(content.InnerHTML, "<h4 class=""dataHeaderWithBorder"">") i = 0 ReDim sections(0) As String For Each dataHeader In dataHeaders v = Split(dataHeader, vbCrLf)(0) sections(i) = Split(v, "</h4>")(0) sections(i) = Replace(sections(i), " ", "") sections(i) = Trim(sections(i)) i = i + 1 ReDim Preserve sections(i) As String Next i = i + 1 ReDim Preserve sections(i) As String Application.Goto Sheets("Foglio1").Range("A1") ActiveSheet.UsedRange.Clear i = 0 kk = 0 Set myColl = IE.Document.getElementsbyTagName("TABLE") For Each myItm In myColl i = i + 1 kk = kk + 1 Cells(i, "A").Value = "TABELLA_" & kk Cells(i, "D").Value = sections(kk) For Each trtr In myItm.Rows For Each tdtd In trtr.Cells Cells(i + 1, j + 1) = tdtd.InnerTEXT j = j + 1 Next tdtd i = i + 1: j = 0 Next trtr i = i + 2 Next myItm 'Legge le tabelle dentro gli iframe: kk = 0 i = 1 Set myColl = IE.Document.getElementsbyTagName("iframe") For f = 0 To myColl.Length - 1 If Left(myColl(f).ID, 7) = "myframe" Then Set my2Coll = myColl(f).contentDocument.getElementsbyTagName("table") For Each myItm In my2Coll i = i + 1 Set myRColl = myItm.getElementsbyTagName("tr") For Each myR In myRColl Set myDColl = myR.getElementsbyTagName("td") For Each myTD In myDColl Cells(i + 1, j + 1) = myTD.InnerTEXT j = j + 1 Next myTD i = i + 1: j = 0 Next myR i = i + 2 Next myItm End If Next f Range("A1").Select ActiveSheet.UsedRange.WrapText = False IE.Quit Set IE = Nothing MsgBox "Finito!" End Sub
Che dire: sei un grande!
Anche se il risultato è da pulire, ho tutte le informazioni che mi servono. Sul foglio ci faccio quasi tutto, è dall'esterno che avevo difficoltà.
Ho dovuto aggiustare 3 cose;
1- da così:
Private Declare Sub Sleep Lib "kernel32" (ByVal dwMilliseconds As Long)
a così:
Private Declare PtrSafe Sub Sleep Lib "kernel32" (ByVal dwMilliseconds As Long)
in quanto uso un sistema a 64 bit;
2- ho rimosso la dicitura TABELLA e spostato il dato di mio interesse sulla colonna A:
`' Cells(i, "A").Value = "TABELLA_" & kk <<<<<<rimosso ' Cells(i, "D").Value = sections(kk) <<<<rimosso Cells(i, "A").Value = sections(kk)
3- poi ho cambiato il foglio dall'uno a tre, giusto per applicarlo al progetto in corso.
Resta quindi solo un pochino di pulizia e commentare (e su tutte le voci per html, passo). Per quanto riguarda le variabili e diciture varie, puoi utilizzare quelle che ti piacciono di più, essendo parti di codici prese qua e la da internet, ho fatto parecchia confusione.
Grazie grazie davvero.
Ora vorrei complicare leggermente le cose: pensi sia troppo disturbarti ulteriormente per aggiungere una piccola sezione di codice, che faccia estrarre solo le parti di mio interesse in base ai titoli delle tabelle?
In pratica a me interessano solo queste tabelle:
- Directed
- Writing Credits
- Cast
- Music
- Cinematography
- Film Editing
Se aggiungo un mio elenco (tipo come quello che mi dicevi in uno dei primi post):
Const TITLES as String = "Directed,Writing Credits,Cast,Produced,Music,ecc"
e facendogli caricare solo la tabella corrispondente con il TITLES inserito da me?
vecchio frac ha scritto:
Ah ecco Sleep, la puoi togliere perchè all'inizio pensavo di sì ma poi non l'ho utilizzata.
Non conosco la parte che richiama al codice html... mi sarebbe utile una leggere spiegazione per capire come migliorarlo per rendere più efficiente il foglio risultante.
vecchio frac ha scritto:
Ok per il resto. Appena ho un attimo ti descrivo sommariamente il codice, ma in fondo è abbastanza semplice; dimmi solo se sono sulla giusta strada.
Non ho fretta, fai pure con comodo, intanto faccio qualche prova anche io... vediamo se ci riesco; dimmi solo se sono sulla giusta strada.
Ho semplificato un pochino, togliendo il codice (secondo me inutile) relativo agli iFrames che tanto non veniva eseguito 🙂
Anche la gestione dei tag H4, da cui si ricava il titolo di ogni sezione, si poteva ricavare in modo più semplice.
Option Explicit Sub GetWebTab2_VF2() Dim IE As Object Dim f As Long Dim kk As Long, i As Long, j As Long Dim myColl As Variant Dim myItm As Variant Dim myURL As String Dim v As Variant Dim trtr As Variant, tdtd As Variant Dim sections As Variant myURL = "https://www.imdb.com/title/tt0227445/fullcredits?ref_=tt_cl_sm#cast" 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 Set sections = IE.Document.getElementsbyTagName("H4") Application.Goto Sheets("Foglio1").Range("A1") ActiveSheet.UsedRange.Clear i = 0 kk = 0 Set myColl = IE.Document.getElementsbyTagName("TABLE") For Each myItm In myColl i = i + 1 Cells(i, "A").Value = sections(kk).innertext For Each trtr In myItm.Rows For Each tdtd In trtr.Cells Cells(i + 1, j + 1) = tdtd.innertext j = j + 1 Next tdtd i = i + 1: j = 0 Next trtr i = i + 2 kk = kk + 1 Next myItm Range("A1").Select ActiveSheet.UsedRange.WrapText = False IE.Quit Set IE = Nothing MsgBox "Finito!" End Sub
Ora vorrei complicare leggermente le cose
Non avevo visto questo post... fammici riflettere 🙂
Ci stavo riflettendo.... non ti faccio impazzire più di tanto, creo una sub che applichi un filtro al foglio appena popolato, ripulendo e lasciando solo le cose che mi interessano.
Segno quindi come risolto... se poi ti viene in mente un metodo che faccia estrarre solo i dati di mio interesse, ben venga.
Grazie infinite per il momento.
Come vuoi, però non trovo grosse difficoltà, mi ci stavo già dedicando 🙂
Allora, se non è troppo disturbo, diventerebbe tutto più pulito, Grazie
Ecco la nuova revisione del codice.
La particolarità è (può piacere oppure no, valuta tu) che se nella costante TITLES metti solo "Cast", viene restituita ogni sezione che contenga "Cast". Altrimenti devi essere preciso e indicare il titolo completo della sezione (ad esempio " Cast (in credits order) verified as complete ").
Ho aggiunto una funzione "contains" che verifica appunto se una stringa è contenuta in una lista di nomi.
Option Explicit Const TITLES As String = "Directed by,Music by,Cast" Sub GetWebTab2_VF2() Dim IE As Object Dim f As Long Dim kk As Long, i As Long, j As Long Dim myColl As Variant Dim myItm As Variant Dim myURL As String Dim v As Variant Dim trtr As Variant, tdtd As Variant Dim sections As Variant myURL = "https://www.imdb.com/title/tt0227445/fullcredits?ref_=tt_cl_sm#cast" 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 Set sections = IE.Document.getElementsbyTagName("H4") Application.Goto Sheets("Foglio1").Range("A1") ActiveSheet.UsedRange.Clear i = 0 kk = 0 Set myColl = IE.Document.getElementsbyTagName("TABLE") For Each myItm In myColl If contains(TITLES, sections(kk).innertext, ",") Then i = i + 1 Cells(i, "A").Value = sections(kk).innertext For Each trtr In myItm.Rows For Each tdtd In trtr.Cells Cells(i + 1, j + 1) = tdtd.innertext j = j + 1 Next tdtd i = i + 1: j = 0 Next trtr i = i + 2 End If kk = kk + 1 Next myItm Range("A1").Select ActiveSheet.UsedRange.WrapText = False IE.Quit Set IE = Nothing MsgBox "Finito!" End Sub Private Function contains(list As Variant, item As String, Optional delimiter As String = " ") As Boolean Dim itm As Variant If IsMissing(delimiter) Then delimiter = " " contains = False For Each itm In Split(list, delimiter) contains = InStr(LCase(item), LCase(itm)) If contains Then Exit Function Next End Function
Ti ringrazio di cuore vecchio frac, così è perfetto. La funzione contains è molto interessante....
Credo che così siamo decisamente a posto! Grazie
Appena riesco ti aggiungo un breve commento al codice. Se non rispondo in un paio di giorni fammi un promemoria, perchè la tecnica usata può essere interessante per chiunque voglia leggere il thread 🙂
Appena riesco ti aggiungo un breve commento al codice. Se non rispondo in un paio di giorni fammi un promemoria, perchè la tecnica usata può essere interessante per chiunque voglia leggere il thread
Ok. Io intanto se lo perfeziono e lo adatto al mio scopo, inoltro gli sviluppi. Grazie
Appena riesco ti aggiungo un breve commento al codice. Se non rispondo in un paio di giorni fammi un promemoria, perchè la tecnica usata può essere interessante per chiunque voglia leggere il thread
Solo un promemoria come richiesto. Grazie
Grazie a te (anche in privato va bene).
Non ho avuto ancora occasione di farlo infatti, scusami.
Riallego il codice con qualche riga di commento.
In sostanza la mia proposta si basa fortemente sul tuo approccio iniziale, con il doppio correttivo (riportare i titoli delle sezioni e limitare la ricerca alle sole sezioni specificate).
Il punto di partenza è impostare un riferimento a un oggetto di tipo applicazione internet, raggiungere con questo la pagina desiderata, assegnarvi il contenuto della stessa e poi, con i metodi propri di tale oggetto, filtrare i tag che separano le varie sezioni del documento (il tag "H4"). Questo l'ho capito esaminando il codice sorgente della pagina internet originale, per fortuna è omogenea e fatta bene 🙂
All'interno di ogni sezione si recupera il testo delle diverse tabelle e lo si riporta in Excel, riga per riga.
HTH
'la direttiva seguente serve per la dichiarazione obbligatoria delle variabili Option Explicit 'la costante TITLES serve da filtro per le sezioni da recuperare Const TITLES As String = "Directed by,Music by,Cast" 'scopo della procedura è legegre una pagina internet, 'recuperare i titoli delle sezioni delle diverse tabelle di cui è composta, 'leggendone il contenuto e inserendo in Excel 'il titolo della sezione con il relativo contenuto. 'E' possibile limitare la lettura delle sezioni desiderate 'modificando opportunamente la costante TITLES Sub GetWebTab2_VF2() 'dichiarazione delle variabili e loro tipizzazione Dim IE As Object ' un oggetto web browser che punta a un sito Dim i As Long, j As Long, kk As Long ' variabili contatori di supporto Dim myColl As Variant ' contiene il contenuto della pagina internet Dim myItm As Variant ' ogni elemento di sezione dentro la pagina internet Dim myURL As String ' indirizzo internet da raggiungere Dim trtr As Variant, tdtd As Variant ' riferimenti alle righe delle tabelle della pagina internet Dim sections As Variant ' qui sono contenuti i titoli delle diverse sezioni, ' che poi saranno filtrati dalla costante iniziale 'imposta internet l'indirizzo da raggiungere myURL = "https://www.imdb.com/title/tt0227445/fullcredits?ref_=tt_cl_sm#cast" 'crea l'oggetto internet explorer Set IE = CreateObject("InternetExplorer.Application") 'legge il contenuto della pagina internet 'e lo assegna alla variabile IE '(metodo classico) With IE .Navigate myURL .Visible = True Do While .Busy: DoEvents: Loop 'Attesa not busy Do While .ReadyState <> 4: DoEvents: Loop 'Attesa documento End With 'imposta un riferimento all'insieme degli elementi con tag H4 della pagina internet Set sections = IE.Document.getElementsbyTagName("H4") 'si posiziona sul foglio Excel desiderato per riversarvi i dati 'e cancella la zona usata in precedenza Application.Goto Sheets("Foglio1").Range("A1") ActiveSheet.UsedRange.Clear 'imposta un riferimento all'insieme degli elementi della sezione TABLE del documento 'e scorre ogni elemento per recuperarne il contenuto desiderato 'se il testo della sezione è contenuto nella costante TITLES 'di ogni elemento, poichè è memorizzata come tabella, 'scorre riga per riga e ne ricava il testo, che inserisce nel foglio Excel 'in una riga dedicata, indentando a partire dalla colonna A in avanti i = 0 kk = 0 Set myColl = IE.Document.getElementsbyTagName("TABLE") For Each myItm In myColl If contains(TITLES, sections(kk).innertext, ",") Then i = i + 1 Cells(i, "A").Value = sections(kk).innertext For Each trtr In myItm.Rows For Each tdtd In trtr.Cells Cells(i + 1, j + 1) = tdtd.innertext j = j + 1 Next tdtd i = i + 1: j = 0 Next trtr i = i + 2 End If kk = kk + 1 Next myItm 'operazioni finali Range("A1").Select ActiveSheet.UsedRange.WrapText = False 'esce dall'applicazione internet e distrugge l'oggetto in memoria IE.Quit Set IE = Nothing MsgBox "Finito!" End Sub 'la funzione contains determina se un elemento stringa è presente in una lista di elementi, 'passata anch'essa come stringa in cui gli items sono separati da un delimitatore 'se non si specifica un delimitatore viene assunto il carattere spazio 'esempio: 'contains("uno;due;tre", "due", ";") restituisce TRUE 'contains("uno;due;tre", "due", ",") restituisce FALSE Private Function contains(list As Variant, item As String, Optional delimiter As String = " ") As Boolean Dim itm As Variant contains = False For Each itm In Split(list, delimiter) contains = InStr(LCase(item), LCase(itm)) If contains Then Exit Function Next End Function
Che dire, tutto molto chiaro, e per un auto-didatta come me, avere commenti così chiari nel codice sono una manna dal cielo per capire bene lo svolgersi degli eventi.
Spero che questo esempio possa essere d'aiuto anche per altri utenti che vorranno prelevare informazioni mirate da pagine internet analoghe.
Ti ringrazio davvero tanto.
-
AutoreArticoli