Valutazione 4.87/ 5 (100.00%) 5838 voti

Condividi:        

Ricavare i Dati da una Pagina Web ed Inserirli su 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

Ricavare i Dati da una Pagina Web ed Inserirli su Excel

Postdi Maury170419 » 19/03/20 23:13

Ciao a Tutti mi chiamo A.Maurizio
E il mio problema e questo :
Io vorrei sapere come poter ricavare i dati aggiornati sul Coronavirus
che trovo su questo link : https://lab24.ilsole24ore.com/coronavirus

E una volta premuto un Tasto posizionato sul Foglio di Excel
Da codice si dovrebbe ricavare tutti i dati inerente a tale foglio .
Chiaramente pensavo che dopo aver risolto grazie a voi un altro programma inerente alle previsioni meteo , Mi fosse tutto molto più semplice da capire il tutto ; Ma vedo che non è cosi .
Pertanto vi chiedo ancora una volta di aiutarmi in merito a questo mio altro problema grazie.
(P.S) Premetto che io di mio ho buttato giù un paio di righe di codice , Scopiazzare qua e la
Senza ricavare un ragno dal buco

Questo e il mio link per scaricare il file di prova Grazie:
https://app.box.com/s/a0l5vxo7dr7tb6oms6dxca7qh27fypp0

Saluti da A.Maurizio
Maury170419
Utente Senior
 
Post: 110
Iscritto il: 31/10/16 09:05

Sponsor
 

Re: Ricavare i Dati da una Pagina Web ed Inserirli su Excel

Postdi Anthony47 » 21/03/20 01:08

Queste automazioni sono solo un gioco di tempo e di pazienza, merce rara anche in questi giorni...

Inoltre i grafici sono tutti sviluppati con script, e infatti la tua macro che cerca dati tabellari restituisce zero.
Per scopi puramente ludici ho sviluppato il file scaricabile qui: https://www.dropbox.com/s/0ajk6yckhir74 ... .xlsm?dl=0

Contiene la macro TabellaSole, che consente di esaminare la pagina del Sole24h ed estrarre molti dei dati presenti. Eseguitela per estrarre i dati aggiornati.
Se vi viene restituito un errore di vba allora potrebbe esserci un problema di compatibilita' derivante dalla gestione di sicurezza di InternetExplorer; per aggirarlo bisogna disattivare la modalita' protetta di IE: Menu /Strumenti /Opzioni; tab Sicurezza, togliere la spunta alla voce "Attiva modalita' protetta"; a questo punto si chiude IE, si interrompe la macro, e si riparte da zero.
Anche se IE oramai viene usato per poche operazioni, suggerisco di ripristinare il livello di sicurezza quando e' terminata l'importazione.

Inizialmente ero partito per estrarre solo la tabella che c'e' dietro il grafico " L’andamento nelle province con più contagi", poi ho visto che lo stesso metodo e' applicabile su altre sezioni e ho allargato l'importazione, una sezione per foglio.
Comunque questo metodo non funziona su tutte le sezioni.
Nei fogli dove l'importazione tabellare fallisce vi dovete accontentare dell'screenshot del grafico e dell'indirizzo dove potete trovare l'originale (vedi cella M1)

Con ancora tanta pazienza e un po' di tempo si potrebbe certamente ottenere l'importazione completa, ma personalmente la presentazione del Sole mi pare molto fruibile; e in cuor mio spero che l'utilita' di un lavoro come questo sia di breve durata

Per il posteri, il codice della macro e delle sue subordinate:
Codice: Seleziona tutto
'   >>> RIGOROSAMENTE IN CIMA A UN MODULO STANDARD DEL VBA <<<
#If VBA7 Then
    Declare PtrSafe Sub Sleep Lib "kernel32" (ByVal dwMilliseconds As LongPtr)
    Declare PtrSafe Function SetForegroundWindow Lib "user32.dll" (ByVal hwnd As LongPtr) As LongPtr
    Declare PtrSafe Function GetForegroundWindow Lib "user32.dll" () As LongPtr
#Else
    Declare Sub Sleep Lib "kernel32" (ByVal dwMilliseconds As Long)
    Declare Function SetForegroundWindow Lib "user32.dll" (ByVal hwnd As Long) As Long
    Declare Function GetForegroundWindow Lib "user32" () As Long
#End If

Dim IE As Object, wHand, eHand

Sub TabellaSole()
Dim IESh As Worksheet, FlEx As Boolean, myTim As Single
Dim aColl As Object, bColl As Object, myIfr As Object, myItm As Object
Dim myURL As String, iSh As Long, Rispo, tVar
Dim IFSrc As String, FlourData As String, iLabel As Long, iNLabel As Long
Dim dHTDoc As Object, I As Long, aTest
Dim ifHtm As String, Flourish As String, cLabel As String, tIfr As Long


Sheets(1).Select
                                               
If IE Is Nothing Then Set IE = CreateObject("InternetExplorer.Application")
myURL = "https://lab24.ilsole24ore.com/coronavirus/"

eHand = Application.hwnd        'IE Hwnd
Dim ArrOne()
'Memorizzo iframe scr e titolo:
    NavigaTo (myURL)
    wHand = GetForegroundWindow()
    Set aColl = IE.document.getelementsbytagname("iframe")
    Set bColl = IE.document.getelementsbytagname("section")
    ReDim ArrOne(0 To aColl.Length - 1, 1 To 2)
    For I = 0 To aColl.Length - 1
        ArrOne(I, 1) = aColl(I).getAttribute("src")
        ArrOne(I, 2) = bColl(I + 1).getelementsbytagname("h2")(0).innertext
    Next I
'Scansiono ogni iFrame src:
Do
iSh = iSh + 1       'indice generico
DoEvents
If iSh > Worksheets.Count Then Worksheets.Add after:=Sheets(Worksheets.Count)
Sheets(iSh).Select
    Range("A:Z").ClearContents
    iLabel = 0: aTest = 0
        Range("A1").Value = ArrOne(iSh - 1, 2)
        Range("M1") = ArrOne(iSh - 1, 1)
        IFSrc = ArrOne(iSh - 1, 1)
        NavigaTo IFSrc
        If IE.LocationURL = IFSrc Then      'Pagina raggiunta?
            ifHtm = IE.document.getelementsbytagname("body")(0).innerHTML
            'Labels:
            Flourish = Replace(Mid(ifHtm, InStr(1, ifHtm, "_Flourish_data_column_names", vbTextCompare)), Chr(34), "", , , vbTextCompare)
            tVar = GimmeValArr(Flourish)
            If IsArray(tVar) Then
                Range("B2").Resize(1, UBound(tVar) + 1) = tVar      'Set Label
            End If
            'Datas:
            Flourish = Replace(Mid(ifHtm, InStr(1, ifHtm, "_Flourish_data =", vbTextCompare)), Chr(34), "", , , vbTextCompare)
            Do
            DoEvents
            Sleep 10
                iLabel = iLabel + 1
                'get Label:
                iNLabel = InStr(iLabel, Flourish, "{label:", vbTextCompare) + Len("{label:")
                If iNLabel < iLabel Then Exit Do
                FlourData = Mid(Flourish, iNLabel)
                cLabel = Mid(FlourData, 1, InStr(1, FlourData, ",", vbTextCompare) - 1)
                Range("A3").Offset(aTest, 0).Value = cLabel
                tVar = GimmeValArr(FlourData)
                If IsArray(tVar) Then
                    Range("B3").Offset(aTest, 0).Resize(1, UBound(tVar) + 1) = tVar
                End If
                aTest = aTest + 1       'Offset dalla base A3
                iLabel = iNLabel        'Prepara per next
            Loop
        End If
        'Aggiunge screenshot
        Rispo = SetForegroundWindow(wHand)          'Focus su IE
        Call ScreenShotIE(Sheets(iSh).Name)
If iSh > UBound(ArrOne) Then Exit Do
Loop

'
MsgBox ("Completato...")
On Error Resume Next
IE.Quit
Set IE = Nothing


End Sub



Sub NavigaTo(LURL As String, Optional ByVal TOBusy As Single = 5, Optional ByVal TODoc As Single = 10)
'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
    Sleep 100
    Do While .Busy                  'Attesa not busy
        DoEvents: If Timer > (myTim + TOBusy) Then Exit Do
        If Timer < myTim And Timer > TOBusy Then Exit Do
        Sleep 100
    Loop
    Do While .readyState <> 4:      'Attesa documento
        DoEvents: If Timer > (myTim + TODoc) Then Exit Do
        If Timer < myTim And Timer > TODoc Then Exit Do
        Sleep 100
    Loop
End With
'
'Attesa addizionale
Sleep 500
End Sub


Function GimmeValArr(ByVal iStr As String) As Variant
Dim myLSplit, iInd As Long, eInd As Long

iInd = InStr(1, iStr, "[", vbTextCompare) + 1
eInd = InStr(iInd, iStr, "]", vbTextCompare) + 0
If eInd < iInd Then eInd = iInd
myLSplit = Split(Mid(iStr & "[ ]", iInd, eInd - iInd), ",", , vbTextCompare)
If UBound(myLSplit) < 1 Then
    GimmeValArr = False
Else
    GimmeValArr = myLSplit
End If
End Function

Sub ScreenShotIE(ByVal TSh As String)
'Dim IE As Object

Range("M3").Select
On Error Resume Next
    ActiveSheet.Pictures("ZCZCImg").Delete
On Error GoTo 0

Application.SendKeys "(%{1068})"
On Error Resume Next
    AppActivate "Microsoft Excel"   'sembrano inefficaci...
    AppActivate "Excel"
On Error GoTo 0

Sleep 50
SetForegroundWindow (Application.hwnd)
Sleep 300
Sheets(TSh).Paste
Selection.ShapeRange.Name = "ZCZCImg"
Selection.ShapeRange.Width = Application.Width / 2.5
ActiveWindow.RangeSelection.Select
End Sub


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

Re: Ricavare i Dati da una Pagina Web ed Inserirli su Excel

Postdi Maury170419 » 21/03/20 15:27

Ciao Anthony47 come stai con questo corona virus ?
Poi per prima cosa : Come sempre vorrei farti i miei più sinceri complimenti per il tuo Programma che mi hai Offerto.
però forse non sono riuscito a spegarmi come avrei dovuto nei tuoi confronti; In quanto Copiando di sana pianta il tuo Programma
Esso non fa nulla che darmi sul foglio 2 ( Il Link : Nella cella (M1) Del sito in questione e fin qui potrebbe anche starmi bene!

Idem per la Cella (A1) dove viene riportato il Trend del Giorno.

mentre nella Riga (A3:E3) Vengono solo Riportate le diciture pari a :
1) (ish_data = {data:[{color:Attualmente positivi)
2) ({color:Attualmente positivi)
3) (facet:Totali)
4) (filter:Totali)
5) (metadata:[\u003cspan\n style=\font-size:5em;
color:#F5958F\>311\u003c/span>)

e nulla di più.
Mentre io vorrei poter ricavare tutti i dati dell'interapagina Web
Meno i Grafici che le preleverò in un secondo momento .
Ma quello ho già grazie sempre a te imparato a farlo?
Tutto qui!
Ciao - Grazie Come sempre per la tua disponibilità - e Buona Giornata.
Da A.Maurizio
Maury170419
Utente Senior
 
Post: 110
Iscritto il: 31/10/16 09:05

Re: Ricavare i Dati da una Pagina Web ed Inserirli su Excel

Postdi Maury170419 » 21/03/20 16:40

Scusami Tanto Anthony47
Per la mia Gaf.... di prima
Ma era semplicemente dovuta dal fatto che non avevo fatto leggere la tua giusta procedura al Tasto Premuto; In quanto avevo ancora inserito la chiamata al mio Progetto e non al tuo
Tutto qui !
Ora funziona a meraviglia
Grazie come Sempre!

Ora non mi resta altro che richiamare la visualizzazione per settore , Delle Immagini : Inerenti agli andamenti del tipo chart
Cosa che penso non siano tanto difficili da ottenere .
Grazie comunque !
Sei sempre fantastico oltre che il migliore.
Ciao da A.Maurizio
Maury170419
Utente Senior
 
Post: 110
Iscritto il: 31/10/16 09:05

Re: Ricavare i Dati da una Pagina Web ed Inserirli su Excel

Postdi Maury170419 » 21/03/20 17:03

Scusami Tanto Anthony47
Per la mia Gaf.... di prima
Ma era semplicemente dovuta dal fatto che non avevo fatto leggere la tua giusta procedura al Tasto Premuto; In quanto avevo ancora inserito la chiamata al mio Progetto e non al tuo
Tutto qui !
Ora funziona a meraviglia
Grazie come Sempre!

Ora non mi resta altro che richiamare la visualizzazione per settore , Delle Immagini : Inerenti agli andamenti del tipo chart
Cosa che penso non siano tanto difficili da ottenere .
Grazie comunque !
Sei sempre fantastico oltre che il migliore.
Ciao da A.Maurizio
Maury170419
Utente Senior
 
Post: 110
Iscritto il: 31/10/16 09:05


Torna a Applicazioni Office Windows


Topic correlati a "Ricavare i Dati da una Pagina Web ed Inserirli su Excel":


Chi c’è in linea

Visitano il forum: Nessuno e 13 ospiti