Recuperare dati da una Pagina Web per le previsioni Meteo

[Maury170419]

Ciao a Tutti mi chiamo Maurizio
E anche se capisco che siamo alle solite ; Vi chiedo un ulteriore Aiuto .
Il problema e questo :
Su di una foglio di Excel Vorrei poter Estrapolare solo alcuni dati di una pagina Web Inerente alle Previsioni Meteo
In quanto : Quella che mi avevate gentilmente preparato voi un po' di tempo fa ; non funziona più !!!!
In quanto andando a leggere a fondo la sua struttura attuale , mi sono accorto che lo hanno cambiato drasticamente ; Pertanto tutti parametri di lettura e scrittura di prima non servono più.
Io ho provato a fare di tutto pur di non rompervi le scatole ulteriormente a voi tutti .
Ma : Attualmente non sono riuscito a ricavare un ragno dal buco ; ho quasi !!!!
Il problema è che non funziona come lo vorrei modificare io

Comunque per Agevolarvi le cose vi inserisci il mio file di prova che e questo :
https://app.box.com/s/pfj1az9p8pgqbwvxiqffj5eaoy0hklsy

Al suo interno troverete le spiegazioni di come vorrei che venissero estrapolate questi dati e come ?

Grazie ancora di tutto cuore per tutti gli aiuti che mi avete sempre dato in merito alle mie richieste.
Sinceri saluti da A.Maurizio

[Maury170419]

Ciao Anthony ti scrivo per darti una buona notizia
In quanto :
1 ) Per prima cosa non smetterò mai di ringraziare te e tutto il tuo staff di (PC-Facile)
In quanto per molti anni vi ho fatto sorridere e incavolare con le mie richieste più strampalate e non ; Ma ha me sono servite molto;
Perché oggi posso raccogliere ciò che ho seminato grazie a voi
2 ) Per me i dati da estrapolare da interne sino ad ora sono sempre statti un pochino un rompicapo
Ma ora non più di tanto .
E questo e il motivo per qui ti scrivo di non tenere più conto della mia richiesta , In quanto a forza di fare sono riuscito a risolvere tutti i miei problemi inerenti a questa mia richiesta .
E questo e il risultato finale ; Vedi Immagine :

https://www.dropbox.com/s/qp43qjptfpsqlu3/Immagine%20Sito%20Meteo.JPG?dl=0


Grazie di tutto saluti sinceri da A:Maurizio

[Maury170419]

Scusatemi se vi disturbo per cosi poco
Però mi sono accorto solo ora che ho un problema che non riesco a risolvere senza il vostro aiuto
Il Problema e questo :

Per Risolvere Il Problema Di Condivisione Dei Dati Tra La Pagina Web ed Excel
ho modificato questo codice da voi gentilmemte offerto un pò di tempo fa; e fin qui tutto ok

il Problema però che non mi estrapola il link inerente all'immagine
Ho provato anche qui a modificare tutte le voci che ho trovato sulla pagina web ; Ma non riesco a ricavare nulla.

Potete cortesemente darmi una mano in merito Grazie
Questo e il listato di Base :

Codice: Seleziona tutto

Sub GetWheatherSub(ByVal myURL As String)
'On Error Resume Next

'X = Foglio1.Range("J1").Value & ""
'Y = Foglio1.Range("J2").Value & ""

'Va Chiamata passandogli l'URL da leggere
myURL = "https://www.meteolive.it/previsione-meteo/italia/Piemonte/Torino/oggi/"
Set Ie = CreateObject("InternetExplorer.Application")
   
With Ie
.Navigate myURL
.Visible = False

Do While .Busy: DoEvents: Loop
Do While .ReadyState <> 4: DoEvents: Loop

End With

Do
    DoEvents
    If Timer > myStart + 2 Or Timer < myStart Then Exit Do
Loop

'Scrive sul Foglio Attivo
On Error Resume Next
'color-00
Set OggCol = Ie.Document.getElementsByClassName("table-wrapper")
Set OggCol3 = OggCol(0).getElementsByTagName("table")

Set OggCol6 = Ie.Document.getElementsByClassName("Table")

'###########################################################################
With Ie.Document
Sheets("Foglio1").Range("A6").Value .getElementsByTagName("tbl-type-2")(1).innerHTML
           
'Sheets("Foglio1").Range("A5").Value = .getElementsByTagName("p")(0).innertext 'prints "Example Domain"
           
Sheets("Foglio1").Range("A6").Value = .getElementsByTagName("td")(2).innertext
End With
'###########################################################################

For I = 0 To OggCol2.Length

With Foglio1
.Range("A12").Offset(I, 0) = OggCol2(I).innertext
       
.Range("A6").Offset(0, I) = OggCol6(I).innertext

.Range("E4").Offset(I, 0) = OggCol7(I).innertext
       
.Range("H30").Offset(I, 0) = OggCol4(I).innertext

.Range("I30").Offset(I, 0) = OggCol5(I).innertext

'.Range("A30").Copy

'.Range("A9").PasteSpecial Paste:=xlPasteAll, Operation:=xlNone, SkipBlanks:= _
'False, Transpose:=True

'.Range("H30:H34").Copy

'.Range("B9").PasteSpecial Paste:=xlPasteAll, SkipBlanks:= _
'False, Transpose:=True

'.Range("I30:I34").Copy

'.Range("B10").PasteSpecial Paste:=xlPasteAll, SkipBlanks:= _
'False, Transpose:=True

.Range("B30").Offset(I, 1) = Replace(OggCol3(I).getattribute("src"), "//", "https://", , , vbTextCompare)

End With

Next I
On Error GoTo 0

Foglio1.Range("A:A").WrapText = False

'Chiusura IE
Ie.Quit
Set Ie = Nothing


Grazie e Buon Fine Settimana

[Anthony47]

Ti ringrazio per le belle parole e complimenti per i risultati

Per quanto riguarda la richiesta, purtroppo da una macro che non funziona bene non si capisce che cosa si voleva ottenere.
Partendo quindi dalla pagina https://www.meteolive.it/previsione-meteo/italia/Piemonte/Torino/oggi dovresti quindi descrivere che cosa vuoi prelevare, magari spiegando anche quali cose gia' ottieni e quali invece ancora ti mancano.

Ciao

[Maury170419]

Ciao Anthony come sempre un grazie per il tuo interessamento
Detto questo : Il mio progetto non avrebbe bisogno di alcun altro aiuto ; In quanto grazie a te funziona benissimo già di suo.

Il listato che ti ho inserito ieri mancava la parte dell'estrazione dell'immagine, che con tanta pazienza ; E caparbietà sono poi riuscito a portare a termine e a farla evidenziare nella cella (C30) e per fare questo ho apportato queste modifiche
:

Codice: Seleziona tutto

Dim Campo As Range
Dim Forma As Object
Dim Y As String, X As String
Dim Getimgurl As HeaderFooter
Dim OggCol As Object, OggCol2 As Object, OggCol3 As Object, OggCol4 As Object, OggCol5 As Object, OggCol6 As Object, OggCol7 As Object
Dim cell, shp As Shape, Target As Range
Dim rng As Object
Dim filenam As Variant
Dim I As Long

Sub GetWheatherSub(ByVal myURL As String)
On Error Resume Next

X = Foglio1.Range("J1").Value & ""
Y = Foglio1.Range("J2").Value & ""

'Va Chiamata passandogli l'URL da leggere
myURL = "https://www.meteolive.it/previsione-meteo/italia/Piemonte/Torino/oggi/"
Set Ie = CreateObject("InternetExplorer.Application")
   
With Ie
.Navigate myURL
.Visible = True

Do While .Busy: DoEvents: Loop
Do While .ReadyState <> 4: DoEvents: Loop

End With

Do
    DoEvents
    If Timer > myStart + 2 Or Timer < myStart Then Exit Do
Loop

'Scrive sul Foglio Attivo
On Error Resume Next
'color-00   ' Nome di riferimento mio personale

'###################################################################################################################
'Questo e il codice modificato che ieri non avevo messoe pertanto non potyeva estrarmi il link della prima immagine del giorno o del (Momento)

Set OggCol = Ie.Document.getElementsByClassName("table-wrapper")
Set OggCol3 = OggCol(0).getElementsByTagName("color-00")
Set OggCol3 = OggCol(0).getElementsByTagName("img")

Ora però grazie a te e a questo codice ; Il Link corrispondente viene estratto nella cella (C30)
'###################################################################################################################

Set OggCol6 = Ie.Document.getElementsByClassName("Table")

'###########################################################################
With Ie.Document
Sheets("Foglio1").Range("A6").Value .getElementsByTagName("tbl-type-2")(1).innerHTML
           
'Sheets("Foglio1").Range("A5").Value = .getElementsByTagName("p")(0).innertext 'prints "Example Domain"
           
Sheets("Foglio1").Range("A6").Value = .getElementsByTagName("td")(2).innertext
End With
'###########################################################################

For I = 0 To OggCol3.Length

With Foglio1
.Range("A12").Offset(I, 0) = OggCol2(I).innertext
       
.Range("A6").Offset(0, I) = OggCol6(I).innertext

.Range("E4").Offset(I, 0) = OggCol7(I).innertext
       
.Range("H30").Offset(I, 0) = OggCol4(I).innertext

.Range("I30").Offset(I, 0) = OggCol5(I).innertext

'.Range("A30").Copy

'.Range("A9").PasteSpecial Paste:=xlPasteAll, Operation:=xlNone, SkipBlanks:= _
'False, Transpose:=True

'.Range("H30:H34").Copy

'.Range("B9").PasteSpecial Paste:=xlPasteAll, SkipBlanks:= _
'False, Transpose:=True

'.Range("I30:I34").Copy

'.Range("B10").PasteSpecial Paste:=xlPasteAll, SkipBlanks:= _
'False, Transpose:=True

.Range("B30").Offset(I, 1) = Replace(OggCol3(I).getattribute("src"), "//", "https://", , , vbTextCompare)

End With

Next I
On Error GoTo 0

Foglio1.Range("A:A").WrapText = False

'Chiusura IE
'Ie.Quit
Set Ie = Nothing

'Call GetWheatherSub2(myURL2)
End Sub


E fin qui tutto ok

Poi Passa alla Seconda Procedura che dovrebbe Leggere il Link Dell'immagine e la dovrebbe visualizzare che è questa :

Codice: Seleziona tutto

Dim Campo As Range
Dim Forma As Object
Dim I As Long

Sub GetShapeFromWeb(strShpUrl As String, rngTarget As Range)
'On Error Resume Next
    With rngTarget.Parent
       .Pictures.Insert strShpUrl
       .Shapes(.Shapes.Count).Left = rngTarget.Left
       .Shapes(.Shapes.Count).Top = rngTarget.Top
       .Shapes(.Shapes.Count).Height = rngTarget.Height
       .Shapes(.Shapes.Count).Width = rngTarget.Width
    End With
 End Sub

Sub Meteo_Italia()
On Error Resume Next
Dim I As Long

For I = 1 To 1
Call GetShapeFromWeb(Foglio1.Range("B30") & Foglio1.Range("A14"))

Next I

InsertPic
End Sub

Sub InsertPic()
On Error Resume Next
Set myDocument = Worksheets(1)
For Each s In myDocument.Shapes

    Select Case s.Type
   
    Case msoEmbeddedOLEObject, _
            msoLinkedOLEObject, _
            msoOLEControlObject, _
            msoLinkedPicture, msoPicture
           
        s.ScaleHeight 1.55, msoTrue
        s.ScaleWidth 1.55, msoTrue
       
    Case Else
   
        s.ScaleHeight 1.55, msoFalse
        s.ScaleWidth 1.55, msoFalse
       
    End Select
Next

For Each Pict In ActiveSheet.Shapes
' Selection.ShapeRange.LockAspectRatio = msoFalse  '<<Vedi Nota **
Foglio1.Range("A14").Value = ActiveSheet.Shapes
Pict.Height = 55
Pict.Width = 55

Next

 End Sub


Teoricamente a questo punto dovrebbe funzionare tutto a meraviglia ma non è cosi !
in quanto : Pur leggendo il link dell'immagine inserita nella cella (B30) inerente all'immagine del momento
L'immagine non mi viene visualizzata
Cosa che invece dovrebbe comparire nella cella (A14) tutto qui ?
E non capisco il perché

Fai pure con calma non ho fretta
Sei sempre un Amico
Sinceri Saluti da A.Maurizio

[Anthony47]

Allora, tu popoli l'area C30 e successive con l'istruzione
Replace(OggCol3(I).getattribute("src"), "//", "https://", , , vbTextCompare)
Ma il sorgente html gia' ci restituisce il percorso completo dell'immagine (vedi <img src="https://www.meteolive.it/resources/images_for_css/icone-previsioni/sunny.png">), quindi l'istruzione vba citata altera l'indirizzo dell'immagine in https:https://www.meteolive.it/etc etc

Insomma secondo me devi semplificare la compilazione di C30 e successive eliminando quel Replace, quindi:

Codice: Seleziona tutto

.Range("B30").Offset(I, 1) = OggCol3(I).getattribute("src")


Non so come le altre Sub sono collegate alla principale quindi non ho provato il funzionamento collettivo, ma solo la compilazione di C30 con l'url dell'immagine

Ciao

[Maury170419]

Ciao Anthony
Non ti nego che a mio malgrado ci stavo quasi rinunciano
Ieri le avevo provate di tutte
Ma ciò che mi frenava era il fatto che questo listato che avevo preparato ad DOC per un altro progetto funzionava benissimo a
patto che gli metti un link inerente ad una immagine che a sua volta preleverà dalla pagina web incorporata
Che e questa :

Codice: Seleziona tutto

Dim Campo As Range
Dim Forma As Object
Dim I

Sub GetShapeFromWeb(strShpUrl As String, rngTarget As Range)
''On Error Resume Next
    With rngTarget.Parent
       .Pictures.Insert strShpUrl
       .Shapes(.Shapes.Count).Left = rngTarget.Left
       .Shapes(.Shapes.Count).Top = rngTarget.Top
       .Shapes(.Shapes.Count).Height = rngTarget.Height
       .Shapes(.Shapes.Count).Width = rngTarget.Width
    End With
 End Sub
 
Sub Meteo_Italia()
'On Error Resume Next
Dim I As Long

For I = 1 To 1
Call GetShapeFromWeb("https://www.meteolive.it/resources/images_for_css/icone-previsioni/sunny.png", Foglio1.Cells(14, 1))
'https://www.meteolive.it/resources/images_for_css/icone-previsioni/sunny.png
Next I

Call InsertPic
End Sub

Sub InsertPic()
'On Error Resume Next
Set myDocument = Worksheets(1)
For Each s In myDocument.Shapes

    Select Case s.Type
   
    Case msoEmbeddedOLEObject, _
            msoLinkedOLEObject, _
            msoOLEControlObject, _
            msoLinkedPicture, msoPicture
           
        s.ScaleHeight 1.55, msoTrue
        s.ScaleWidth 1.55, msoTrue
       
    Case Else
   
        s.ScaleHeight 1.55, msoFalse
        s.ScaleWidth 1.55, msoFalse
       
    End Select
Next

For Each Pict In ActiveSheet.Shapes
' Selection.ShapeRange.LockAspectRatio = msoFalse  '<<Vedi Nota **
Foglio1.Range("A14").Value = ActiveSheet.Shapes
Pict.Height = 55
Pict.Width = 55

Next

 End Sub


IOra il problema era che io mi ostinavo nel voler farle leggere la Cella Che la procedura (Meteo) mi dava nella Cella (C30)
scrivendola in questo modo :

Codice: Seleziona tutto

Call GetShapeFromWeb("foglio1.Cells(30,3).value", Foglio1.Cells(14, 1).value)
''Call GetShapeFromWeb("https://www.meteolive.it/resources/images_for_css/icone-previsioni/sunny.png", Foglio1.Cells(14, 1))


E se pure come procedura non mi dava nessun tipo di errore
Il Link non veniva letto

E non capisco in oltre anche il perché ?
Mentre al contrario sé le offri un link da leggere : Lui ti preleva l'immagine senza battere ciglio.

Comunque sia Grazie al tuo intervento : Non solo ho capito che ho ancora molta strada da fare prima di riuscire a creare da me un programma di questo genere

Ma che grazie al tuo intervento : Ora funziona benissimo ; Compresa L'immagine che volevo.

Devo solo mettermi li e rifarne uno di sana pianta: togliendo via tutti quei passaggi inutili che non servono a nulla se non a creare confusione ecc...!
Ma il resto funziona Benissimo.
Grazie sempre a te che sei un Grande !!!!!
Ti auguro un buon inizio Settimana
Ciao da A.Maurizio

[Maury170419]

Ciao Anthony
Scusami se ti Importuno ancora una volta con il mio Meteo
Però sono arrivato ad un punto morto che non riesco più a venirne fuori ; Se non con il vostro Aiuto.

Il discorso e questo :
Sto cercando di rifare in Bella una volta per tutte il mio Progetto (Meteo)
E siccome questo (Meteo) viene suddivide in due parti

1 ) Parte Offre L'indicazione Delle Temperature Minime del Momento
2 ) E la Seconda Parte e leggermente più dettagliata in quanto ci sono anche le valutazioni delle (Minime) e Delle (Massime)

Pertanto : Per quanto riguarda la prima parte il meteo funziona alla grande ( Sempre Grazie a Te )
E li sono riuscito a far inserire tutti i dati nelle dovute celle ; Senza usare tanti (Stratagemmi)

Invece Per quanto riguarda il secondo link per accedere alle informazioni della Settimana
Non c'è verso di far prelevare le solo ( Minime ) e / Massime )
che dovrebbero inserirsi nelle celle (B10:B11)
Ti garantisco che ho provato a fare tutte le verifiche del caso senza ricavare Nulla ?
Per cortesia potresti darmi una mano in merito Grazie

Ik Codice in questione e questo :

Codice: Seleziona tutto

Dim Campo As Range
Dim IE
Dim Forma As Object
Dim myStart
Dim Y As String, X As String
Dim Getimgurl As HeaderFooter
Dim OggCol As Object, OggCol1 As Object, OggCol2 As Object, OggCol3 As Object, OggCol4 As Object, OggCol5 As Object, OggCol6 As Object, OggCol7 As Object, OggCol8 As Object, OggCol9 As Object, OggCol10 As Object
Dim cell, shp As Shape, Target As Range
Dim rng As Object
Dim filenam As Variant
Dim I As Long

Sub Previsioni_Meteo2(ByVal myURL2 As String)
'On Error GoTo Finish

X = Foglio1.Range("E1").Value & ""
Y = Foglio1.Range("E2").Value & ""

'Va Chiamata passandogli l'URL da leggere
myURL2 = "https://www.meteolive.it/previsione-meteo/italia/Piemonte/Torino/settimana/"
Set IE = CreateObject("InternetExplorer.Application")
   
With IE
.Navigate myURL2
.Visible = False

Do While .Busy: DoEvents: Loop
Do While .ReadyState <> 4: DoEvents: Loop

End With

Do
    DoEvents
    If Timer > myStart + 2 Or Timer < myStart Then Exit Do
Loop

'Scrive sul Foglio Attivo
On Error Resume Next

Set OggCol = IE.Document.getElementsByClassName("table-wrapper") '- Località Meteo
Set OggCol1 = IE.Document.getElementsByClassName("color-00") '- Minima Attuale

With IE.Document

Sheets("Foglio1").Range("B10").Value .getElementsByTagName("tb")(2).innerText
'Sheets("Foglio1").Range("B11").Value .getElementsByTagName("td")(4).innerText

End With

For I = 0 To OggCol1.Length

With Foglio1
.Range("B10").Offset(I, 0) = OggCol(2).innerText
'.Range("B11").Offset(I, 0) = OggCol3(I).innerText
End With

Next I

On Error GoTo 0

Foglio1.Range("A:A").WrapText = True

'Chiusura IE
IE.Quit
Set IE = Nothing

 'Call Meteo_Italia
'Finish:
End Sub


Nuovamente Grazie
Saluti da Maurizio

[Maury170419]

Ciao Anthony Come Stai ?

Ascolta : Ti scrivo solo per dirti ancora una volta ma in modo definitivo ; Almeno per questa mia Richiesta Di Partenza

Di non tenere più conto dell'ultima mia richiesta
In quanto : Sono riuscito ancora una volta a capire dove stavo sbagliando
Pertanto anche le minime e le massime ora sono state estratte

(P.S) Era solo per un conflitto di Celle che avevo Creato involontariamente tra di loro tutto qui !
Una doveva ricevere un Dato e L'altra un Altro ; Per qui una escludeva l'altra!
E vero tutto ciò mi ha fatto perdere gran parte della Serata; Ma alla fine c'è lo fatta .
Perlomeno i tuoi consigli ; Suggerimenti Passati; Sono Serviti a qualche cosa no ?
Grazie comunque del tuo interesse è dei tuoi proverbiali Aiuti
Sinceri Saluti e Buon Fine Settimana a Tutti voi dello Staff di ( PC-Facile ) da A.Maurizio

[Anthony47]

Bravo
Non so come hai fatto, io farei così:

Codice: Seleziona tutto

Sub Previsioni_Meteo3()
Dim IE As Object, wID As Object, I As Long, oggCOL As Object, oggCOL1 As Object
myURL2 = "https://www.meteolive.it/previsione-meteo/italia/Piemonte/Torino/settimana/"
Set IE = CreateObject("InternetExplorer.Application")
'
With IE
    .Navigate myURL2
    .Visible = False                'MEGLIO se .True
    Do While .Busy: DoEvents: Loop
    Do While .ReadyState <> 4: DoEvents: Loop
End With
myStart = Timer
Do
    DoEvents
    If Timer > myStart + 1 Or Timer < myStart Then Exit Do
Loop
'
'Cerca l'ID "box-previsioni-content":
Set wID = IE.document.getElementById("box-previsioni-content")         'E' il blocco con la tabella delle previsioni settimanali
'Prendi le singole Righe
Set oggCOL = wID.getElementsByTagName("tr")
With Foglio3.Range("B10")
    'di ogni Riga prende 4 elementi:
    For I = 0 To oggCOL.Length - 1
        Set oggCOL1 = oggCOL(I).getElementsByTagName("td")
        If oggCOL1.Length > 4 Then
            .Offset(I, 0) = oggCOL1(0).innerText    'Data
            .Offset(I, 1) = oggCOL1(1).innerText    'Condizioni
            .Offset(I, 2) = oggCOL1(2).innerText    'Minima
            .Offset(I, 3) = oggCOL1(3).innerText    'Max
        End If
    Next I
End With
'
'Chiusura IE
IE.Quit
Set IE = Nothing
End Sub


Confronta col tuo codice e vedi se trovi spunti utili per i tuoi progetti

Ciao

[Maury170419]

Ciao a tutti da Maurizio
Vi scrivo nuovamente da Questo mio precedente posto ho richiesta che sia stata
In quanto quello che vorrei sapere adesso e più o meno analogo alla domanda fatta nel precedente posto.
Sempre ché per tutti voi stia bene .

Allora la mia domanda e questa : Vorrei sapere come devo fare per scaricare dei dati aggiuntivi
Che troverete nella cella (A45) e per non confondere le idee ma esservi di aiuto maggiore
Sul foglio di Excel ho anche inserito l'immagine inerente alla parte che vorrei scaricare che poi troverete nella pagina web.
Chiedo questo perché a dire il vero potrei anche accontentarmi di quanto fatto sino ad ora.
Praticamente quasi tutto ; Però e proprio questa parte che non capisco il perché non si riesca ad estrarre neppure il primo indizio
E siccome voi lo sapete tutti a me piace imparare a programmare bene ; Non vedo il perché non debba continuare a chiedervi Aiuto in merito
Visto che siete i migliori in assoluto Grazie sin da ora per tutto l'aiuto che vorrete darmi in merito
Saluti da A.Maurizio

Link da scaricare il file di prova : https://app.box.com/s/bfli1qjmnhxn1vr5cw51qwxes3uzqjou

[Anthony47]

Non so come integrare il codice per leggere dal sito la tabella "10 Day Weather Forecast" (e' questa che vuoi, vero?) nel tuo progetto, quindi questo lavoro dovrai farlo tu...
Io leggo la tabella col seguente codice:

Codice: Seleziona tutto

Sub Previsioni_Tabella()
Dim CollA As Object, CollB As Object
Dim cSrc As String, cIW As Single
'
X = Foglio1.Range("G1").Value & ""
Y = Foglio1.Range("I1").Value & ""
'
myURL = "https://www.worldweatheronline.com/" & X & "/" & Y & "" & "/it.aspx"
'"https://www.worldweatheronline.com/" & X & "/" & Y & "" & "/it.aspx#pills-tomorrow"
Set IE = CreateObject("InternetExplorer.Application")
'
With IE
    .Navigate myURL
    .Visible = False                    'meglio TRUE
'    .Visible = True
    Do While .Busy: DoEvents: Loop
    Do While .ReadyState <> 4: DoEvents: Loop
End With

Do
    DoEvents
    If Timer > myStart + 2 Or Timer < myStart Then Exit Do
Loop
'
'Importa la tabella "10 Day Weather Forecast"
rbase = "A8"                                                    '<<< Dove scrivere
Set CollA = IE.document.GETelementbyid("lazy_load_14dayfx")     'id della tabella
Call RangeClear(Range(rbase).Resize(12, 6))                     'Cancella contenuto della tabella
'
Set CollB = CollA.getElementsByTagName("div")
ccnt = 99: j = 0
On Error Resume Next
For I = 0 To CollB.Length - 1
    ccl = CollB(I).className
    If InStr(1, "ZcZc" & ccl, "w-100", vbTextCompare) > 0 Or ccnt < 5 Then
        If InStr(1, "ZcZc" & ccl, "w-100", vbTextCompare) > 0 Then ccnt = 0: j = j + 1
        If InStr(1, "ZcZc" & ccl, "w-100", vbTextCompare) = 0 Then
            Range(rbase).Offset(j - 1, ccnt).Value = CollB(I).innerText
            cSrc = "": cIW = 0
            cSrc = CollB(I).getElementsByTagName("img")(0).getAttribute("src")
            If cSrc <> "" Then
                Call GetShapeFromWeb("https:" & cSrc, Range(rbase).Offset(j - 1, ccnt))
                cIW = ActiveSheet.Shapes(ActiveSheet.Shapes.Count).Width
                With Range(rbase).Offset(j - 1, ccnt)
                    .ColumnWidth = 10
                    .ColumnWidth = cIW / .Width * 10
                    .EntireRow.RowHeight = cIW
                End With
            End If
            ccnt = ccnt + 1
        End If
    End If
Next I
On Error GoTo 0

'Chiusura IE
IE.Quit
Set IE = Nothing
End Sub


Sub RangeClear(ByRef myRan As Range)
Dim Shp As Shape
'
myRan.ClearContents
myRan.EntireRow.AutoFit
For Each Shp In ActiveSheet.Shapes
    If Shp.Type = msoPicture Or Shp.Type = msoLinkedPicture Then
        If Not Application.Intersect(Shp.TopLeftCell, myRan) Is Nothing Then
            Shp.Delete
        End If
    End If
Next Shp
End Sub


La prima parte e' quella che gia' usi per aprire il sito; la lettura della tabella avviene dalla riga 'Importa la tabella "10 Day Weather Forecast" in avanti.

La tabella nel sorgente html e' identificata con l'ID "lazy_load_14dayfx"; in questa tabella ogni inizio riga e' caratterizzata dal classname "w-100", e da ogni riga vuoi estrarre 5 dati. Da queste considerazioni scaturisce il codice che vedi elencato sopra.
Il mio codice comprende anche una Sub RangeClear, usata per ripulire contenuti e immagini pre-esistenti dall'intervallo che deve ospitare i nuovi contenuti.
Per inserire l'immagine nella cella uso invece la tua Sub GetShapeFromWeb (su Modulo2_Ins_Image)

Prova, spero sia utile per il tuo lavoro

Ciao

[Maury170419]

Ciao Anthony47 con te non smetterò mai di stupirmi
E vero che avrai studiato; Ma e anche vero che né sai una più del Diavolo
Io ti garantisco che tra una cosa e l'altra e più di una settimana che ci stò lavorando su
Hai anche potuto constatare che quei codici li avevo messi da parte come promemoria
Pertanto le ho usati alla noia ; Ma senza mai ricavare un ragno dal buco.
Ti chiedo umilmente scusa se ogni tanto torno su queste cose , ma non è tanto per le previsioni del tempo che a me interessano; Perché potrebbero anche trattarsi dei Play open di tennis ho di Scacchi
Però visto che mi sembra di aver capito molto da quando ti seguo con attenzione , Dai tuoi interventi e consigli; Pensavo che da questo momento in avanti fossi in grado di cavarmela da solo.
E invece da quanto vedo non è cosi
Ma non importa io non demordo
Grazie ancora infinitamente di tutto Quello che mi hai dato era proprio ciò che avrei voluto fare io .
Sarà per un altra volta ?
Saluti e Grazie e buon lavoro da A.Maurizio

[Maury170419]

Ciao Anthony47
Ascolta : Dopo aver messo a puntino il mio programma con il tuo aiuto, Tutto subito funzionava a meraviglia.
Però ora che lo ripreso per valutare alcune cose , mi viene fuori questa scritta :
Vedere questa Immagine :


Pertanto ho riprovato a mettere un altro tasto per richiamare solo la tua Parte
Ma nulla da fare, non c'é verso di farla funzionare Potresti cortesemente dirmi il perché
E come posso fare per fare funzionare il tutto Grazie
Saluti e Buoin fine Settimana
(P.s) Premetto che il Codice Da me inserito con quel nome , lo messo in un altro modulo in quanto mi serve per estrarre le altre immagini di base Sempre come mi avevi insegnato tu in altre occasioni.
Senza di quello le immagini di base non si vedrebbero tutto qui !
Ciao e ancora Grazie da maurizio

[Anthony47]

Non devi inserire due copie della Sub GetShapeFromWeb, basta quella che avevi gia' inserito in Modulo2_Ins_Image; una Sub infatti e' visibile in tutto il "progetto" (a meno che non sia definita Private)
Ciao

[Maury170419]

Ciao Anthony quello che hai detto e vero ed è una delle prime cose che avevo evitato di fare
La chiamata alle Immagini link sono chiamate in questo modo nel mio Modulo 2:

Codice: Seleziona tutto

Sub GetShapeFromWeb(strShpUrl As String, rngTarget As Range)
'On Error Resume Next
With rngTarget.Parent
.Pictures.Insert strShpUrl
.Shapes(.Shapes.Count).Left = rngTarget.Left '= 1
.Shapes(.Shapes.Count).Top = rngTarget.Top '= 1
.Shapes(.Shapes.Count).Height = rngTarget.Height
.Shapes(.Shapes.Count).Width = rngTarget.Width
End With
End Sub


E poi Segue con :

Codice: Seleziona tutto

Sub Weather_Immagini()
On Error Resume Next
Dim I As Long

For I = 1 To 1
Call GetShapeFromWeb(Foglio1.Range("B8").Value, Foglio1.Range("A2"))
Call GetShapeFromWeb(Foglio1.Range("B9").Value, Foglio1.Range("A5"))
Call GetShapeFromWeb(Foglio1.Range("B10").Value, Foglio1.Range("B5"))
Call GetShapeFromWeb(Foglio1.Range("B11").Value, Foglio1.Range("C5"))
Call GetShapeFromWeb(Foglio1.Range("B12").Value, Foglio1.Range("D5"))
Call GetShapeFromWeb(Foglio1.Range("B13").Value, Foglio1.Range("E5"))
Call GetShapeFromWeb(Foglio1.Range("B14").Value, Foglio1.Range("F5"))
Call GetShapeFromWeb(Foglio1.Range("B15").Value, Foglio1.Range("G5"))

'https://www.meteolive.it/resources/images_for_css/icone-previsioni/sunny.png
Next I

Call InsertPic
End Sub


Per qui come vedi e tutto regolare
Infatti ora sto' provando anche a modificare la procedura ( Previsioni_Tabella )
Usando l'unico modo che a me è più congeniale
Seguendo le regole da te dettate in passato
Anche sé so che ti faccio arrabbiare
Io sto' riprovando questo metodo

Codice: Seleziona tutto

'Importa la tabella "10 Day Weather Forecast"
''rbase = "A18"                                                    '<<< Dove scrivere
Set CollA = IE.document.GETelementbyid("lazy_load_14dayfx")     'id della tabella

Set CollB = CollA.getElementsByTagName("div")
Set CollC = CollB.getElementsByTagName("ZcZc")
Set CollD = CollB.IE.document.getElementsByClassName("w.100")

On Error Resume Next
For I = 0 To CollA.Length - 1

With Sheets("Meteo_Weather")
.Range("A18").Offset(I, 0).Value = CollD(I).innerText

End With

Next I


Ma essendo ché ci sto lavorando da poco ; Per il momento non ricavo nulla
Se non la mia prima parte del programma
Immagini e dati .

Mi manca solo riuscire a far estrarre anche solo uno per volta i tuoi dati e io sarei già contento cosi .
Ma questa e tutta un altra storia.
Ciao e Buon Fine settimana Con simpatia ed Amicizia da Maurizio

[Anthony47]

Anche se so che ti faccio arrabbiare io sto' riprovando questo metodo

Io non mi arrabbio, pero' non capisco la strada che vuoi percorrere...

Esaminiamo il tuo codice:

Set CollA = IE.document.GETelementbyid("lazy_load_14dayfx") 'id della tabella

Ok, ora CollA fa riferimento al "div" che contiene la tabella

Set CollB = CollA.getElementsByTagName("div")

Ora CollB contiene tutti i "div" che sono in CollA (sono 80-90 elementi)

Set CollC = CollB.getElementsByTagName("ZcZc")

Nel sorgente non c'e' nessun tag "ZcZc", quindi CollC rimane vuota.

Set CollD = CollB.IE.document.getElementsByClassName("w.100")

Probabilmente volevi leggere tutti i "div" che marcano l'inizio riga (sono 12), ma avresti dovuto usare Set CollD = CollB. getElementsByClassName("w.100") .Ma anche così, CollD conterrebbe tutti i "div" che marcano l'inizio riga (sono 12) che sono elementi vuoti, e inoltre non danno nessun riferimento ai 5 div successivi che contengono i testi e l'immagine che vuoi scaricare.

For I = 0 To CollA.Length - 1

CollA non e' una collezione ma un singolo HTMLDivElement, quindi non ha una proprieta' Length e di conseguenza l'istruzione va in errore, il ciclo For /Next non viene inizializzato, e le istruzioni all'interno del ciclo vengono eseguite una volta (effetto di On Error Resume Next). Probabilmente volevi ciclare su CollD.Length - 1

.Range("A18").Offset(I, 0).Value = CollD(I).innerText

Se anche CollD contenesse i div di class="W-100", e se il ciclo For /Next fosse stato inizializzato come For I = 0 To CollD.Length - 1, come detto prima questi elementi sono div di separazione e non hanno contenuto.

Insomma capisco che tu stia facendo esercitazioni per apprendere meglio l'uso di questa tecnica, ma ci sono troppi errori nel codice perche' io mi possa fare una idea di come volevi procedere.

Io comincerei a inserire nel tuo codice le istruzioni della mia macro a cominciare dalla riga 'Importa la tabella "10 Day Weather Forecast" fino al successivo On Error GoTo 0

Se poi vuoi fare esercizi, ricorda che devi sempre partire dal codice html dell'elemento che vuoi "puntare"; per visualizzarlo, con la pagina aperta in Edge o Chrome, fai "tasto dx" sull'elemento di cui vuoi visualizzare il sorgente e scegli Esamina o Ispeziona (la stessa operazione su Firefox e' meno efficace); poi scorri /espandi il sorgente e cerca di individuare quali "agganci" hai a disposizione e imposta su di essi il tuo codice.

Ciao

[Maury170419]

Ciao Anthony47
Per prima cosa ti ringrazio per le tue delucidazioni in merito alle mie richieste
Poi provando e riprovando non sono riuscito molto a soddisfare a pieno e soprattutto a velocizzare le varie funzioni
Si vede che in alcuni ambiti i tuoi concetti iniziali funzionano alla grande
Mentre altri dati hanno bisogno di più accortezze per essere scaricati a dovere .
Pertanto sono giunto ad una conclusione che forse e meglio mettere un ( On Error goto Next ) ma usare il tuo programma
Che non riuscire a ricavare un ragno dal buco.
Pertanto l'unica cosa che ti chiedo ancora e sé avessi ancora la voglia di spiegarmi queste due cosine
Che sono :
1 ) A cosa Servono questi due parametri :

Codice: Seleziona tutto

 If InStr(1, "ZcZc" & ccl, "w-100", vbTextCompare) > 0 Or ccnt < 5 Then

Cioè da quello che ho capito io : Tu prelevi da quella griglia di dati solo fino alla (5) Riga
Pertanto se io volessi prendere anche le ultime tre ; Dovrei portare il tuo Cinque a (8)
Giusto ?

2 ) Idem per il parametro della Cancellazione che da :

Codice: Seleziona tutto

 Call RangeClear(Range(rbase).Resize(12, 6))

Andrebbe portata a (12,9) E cosi ?

Però Per Sicurezza, preferisco ridarti il mio lavoro ho parte del mio lavoro , che nella realtà e molto più ampio di tutto questo; In quanto c'é sia la prima parte dei dati comprensiva di immagini che il Traduttore da te Offertomi.

Però tu invio ugualmente questo sia pur ridotto
In quanto : Se trovo già problematiche nel far funzionare questo in questo modo ; Figuriamoci cosa né potrebbe venire fuori con tutt il resto del lavoro precedente.
Questo e il link per scaricare il mio progetto ridotto :
https://app.box.com/s/fxplzlhp4x5auwaiusqzksu5kpit2ekj

Provalo e vedrai che : forse la prima volta che lo provi ti funziona a meraviglia premendo il Tasto (Viola)
Poi dovresti premere il tasto (Celeste) per azzerare i Campi
E poi Ripetere l'operazione con quello (Viola) o (Verde) Per vederne gli effetti finali
Che è poi quello che capita a me !
Fai pure con calma Sei comunque un grande i tutti i sensi Grazie e Buon Fine Settimana

[Anthony47]

Questo e il link per scaricare il mio progetto ridotto :
https://app.box.com/s/fxplzlhp4x5auwaiusqzksu5kpit2ekj

Provalo e vedrai che : forse la prima volta che lo provi ti funziona a meraviglia premendo il Tasto (Viola)
Poi dovresti premere il tasto (Celeste) per azzerare i Campi
E poi Ripetere l'operazione con quello (Viola) o (Verde) Per vederne gli effetti finali
Che è poi quello che capita a me !

Ho immaginato che volessi sottintendere che non tutto fila liscio... E in effetti qualcosa spesso va male...
I miei commenti:
a)On Error Resume Next va usato con discrezione, perche' rischiamo di fargli nascondere situazioni di errore che non dovrebbero esserci (altre volte invece l'errore va messo in conto).
Quindi dal tuo codice della Sub Previsioni_Tabella ho eliminato il primo, subito in testa, riposizionandolo dove la macro comincia a leggere il contenuto della pagina web.

b)Ovviamente questo non avrebbe utilita' se la sessione IE restasse invisibile; per cui l'ho impostata "visibile" (.Visible = True).

Così facendo si vede che spesse volte subito dopo che una sessione IE viene terminata, per parecchi secondi non se ne riesce ad avviarne una nuova e viene aperto un errore su Set IE = CreateObject("internetExplorer.Application")
Premendo "Continua" su questo errore, l'errore puo' ripresentarsi oppure (alla fine) la sessione viene aperta e la macro continua.

c)Ho poi visto che molto spesso IE segnala "Impossibile raggiungere la pagina / Verifica che l'indirizzo Web https://www.worldweatheronline.com sia corretto". Ho pertanto inserito nel codice un "Refresh"della navigazione e la ripetizione del ciclo (If InStr(1, "ZcZc" & IE.document.getelementsbytagname Etc Etc).

d)Inoltre ho visto che qualche volta CollB e' incompleta anche se l'attesa del "IE.Document" e' completata correttamente; d'altra parte questa tabella viene creata al momento via jscript, quindi puo' accadere. Ho pertanto inserito un ciclo che aspetta fino a 6 secondi (For JJ = 1 To 20 /Next JJ)

e)Ho anche inserito una serie di messaggi di Debug, che vengono visualizzati nella "finestra Immediata" del vba; per visualizzare questi messaggi, apri la finestra "Immediata", ogni blocco comincia con ">>>>" (dal vba: premi Contr-g; oppure Menu /Visualizza /Finestra Immediata). Possono essere utili (soprattutto a me) per ricostruire gli eventi.

f)Infine ho usato la funzione Sleep per gestire i timing che ritengo sensibili, previa la sua dichiarazione in testa al modulo (#If VBA7 Then /#Else /#End If)

Il nuovo codice della Sub Previsioni_Tabella con tutte queste modifiche:

Codice: Seleziona tutto

#If VBA7 Then       '!!! ON  TOP  OF  THE  VBA  MODULE   !!!!
    Declare PtrSafe Sub Sleep Lib "kernel32" (ByVal dwMilliseconds As LongPtr)
#Else
    Declare Sub Sleep Lib "kernel32" (ByVal dwMilliseconds As Long)
#End If

Sub Previsioni_Tabella()
'On Error Resume Next

Dim CollA As Object, CollB As Object
Dim cSrc As String, cIW As Single, myStart As Single
Dim IE As Object, SecFl As Boolean

myStart = Timer
Debug.Print ">>>>", Timer
X = Foglio1.Range("G1").Value & ""
Y = Foglio1.Range("I1").Value & ""
'
myURL = "https://www.worldweatheronline.com/" & X & "/" & Y & "" & "/it.aspx"
Set IE = CreateObject("internetExplorer.Application")
Debug.Print TypeName(IE)
'
With IE
Debug.Print myURL, Format(Timer - myStart, "0.00")
    .Navigate myURL
''    .Visible = False                    'meglio TRUE
    .Visible = True
End With
ReDO:
With IE
    Sleep 500
    Do While .Busy: DoEvents: Loop
    Do While .ReadyState <> 4: DoEvents: Loop
End With

Do
    DoEvents
    If Timer > myStart + 2 Or Timer < myStart Then Exit Do
Loop
'
'Importa la tabella "10 Day Weather Forecast"
On Error Resume Next

Debug.Print "Start Import", Format(Timer - myStart, "0.00")
Debug.Print Left(IE.document.getelementsbytagname("body")(0).innertext, 150)

If InStr(1, "ZcZc" & IE.document.getelementsbytagname("body")(0).innertext, "Impossibile raggiungere", vbTextCompare) > 0 And SecFl = False Then
    SecFl = True
Else
    SecFl = False
End If
If SecFl Then
    Debug.Print "Second Chance", Format(Timer - myStart, "0.00")
    IE.Refresh
    Sleep 200
    GoTo ReDO
End If

rbase = "A18"                                                    '<<< Dove scrivere
Set CollA = IE.document.GETelementbyid("lazy_load_14dayfx")     'id della tabella
Call RangeClear(Range(rbase).Resize(12, 9))                     'Cancella contenuto della tabella
'
For JJ = 1 To 20
    Set CollB = CollA.getelementsbytagname("div")
    ccnt = 99: j = 0
    Debug.Print "AA", TypeName(CollB), CollB.Length, Format(Timer - myStart, "0.00"), JJ
    If CollB.Length > 0 Then Exit For
    Sleep 300
Next JJ

For I = 0 To CollB.Length - 1
    ccl = CollB(I).className
    If InStr(1, "ZcZc" & ccl, "w-100", vbTextCompare) > 0 Or ccnt < 8 Then
        If InStr(1, "ZcZc" & ccl, "w-100", vbTextCompare) > 0 Then ccnt = 0: j = j + 1
        If InStr(1, "ZcZc" & ccl, "w-100", vbTextCompare) = 0 Then
            Range(rbase).Offset(j - 1, ccnt).Value = CollB(I).innertext
            cSrc = "": cIW = 0
            cSrc = CollB(I).getelementsbytagname("img")(0).getAttribute("src")
            If cSrc <> "" Then
                Debug.Print "BB", cSrc
                Call GetShapeFromWeb("https:" & cSrc, Range(rbase).Offset(j - 1, ccnt))
                cIW = ActiveSheet.Shapes(ActiveSheet.Shapes.Count).Width
                With Range(rbase).Offset(j - 1, ccnt)
                    .ColumnWidth = 10
                    .ColumnWidth = cIW / .Width * 10
                    .EntireRow.RowHeight = cIW
                End With
            End If
            ccnt = ccnt + 1
        End If
    End If
Next I
Debug.Print "CC", "I=" & I, "cCnt=" & ccnt, Format(Timer - myStart, "0.00")

'Chiusura IE
IE.Quit
Set IE = Nothing
On Error GoTo 0
'Call Weather_Immagini
End
End Sub


Il file così modificato e' scaricabile qui:
https://www.dropbox.com/s/tbv2ldx22uqzs ... .xlsm?dl=0


Quanto alle tue domande:

1) A cosa Servono questi due parametri :

Codice: Seleziona tutto

     If InStr(1, "ZcZc" & ccl, "w-100", vbTextCompare) > 0 Or ccnt < 5 Then


Cioè da quello che ho capito io : Tu prelevi da quella griglia di dati solo fino alla (5) Riga
Pertanto se io volessi prendere anche le ultime tre ; Dovrei portare il tuo Cinque a (8)
Giusto ?

2 ) Idem per il parametro della Cancellazione che da :

Codice: Seleziona tutto

     Call RangeClear(Range(rbase).Resize(12, 6))


Andrebbe portata a (12,9) E cosi ?

La prima istruzione serve a controllare se l'elemento esaminato ha "classname" pari a "w-100" o se siamo all'interno delle prime 5 colonne (non "righe"); quindi corretto che se vuoi importare piu' elementi devi usare "< XX", con XX pari al numero di colonne da importare.

Idem, se importi piu' colonne allora e' corretto usare un "Resize" con piu' colonne nella Call RangeClear.
Come hai correttamente fatto nel codice che hai usato, confermato nel codice da me modificato sopra.

Ciao

[Maury170419]

Ciao Anthony47
Grazie infinite di tutto
Sicuramente passerò la settimana a leggere e rileggere quanto scritto da te sino ad ora
Perché per me tu sei la scuola di informatica vivente che avrei sempre voluta fare , ma che purtroppo all'epoca scelsi di fare altro .
Grazie infinite anche per il tuo progetto è bellissimo e adesso è sempre funzionante , mentre prima funzionava solo alla prima apertura del programma ; poi non si ripeteva più.
Sperò di tutto cuore che anche tu nei prossimi giorni possa fare un pochino di vacanza, Come si dice in questi casi: Un meritato Riposo
Io un pochino meno , ma lo sfrutterò anche per rileggermi tutti i tuoi interventi
Ciao - Grazie ancora di tutto e non smetterò mai di dire che sei il migliore.
Saluti sinceri da A.Maurizio