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