codice:
Option Explicit
Private Declare Function URLDownloadToFile Lib "urlmon" _
Alias "URLDownloadToFileA" (ByVal pCaller As Long, ByVal szURL As String, _
ByVal szFileName As String, ByVal dwReserved As Long, ByVal lpfnCB As Long) As Long
Dim Campo As Range
Dim IE
Dim Forma As Object
Dim myStart
Dim Y As String, X As String
Dim Getimgurl As HeaderFooter
Dim rngTarget As Range
Dim getElementsByTagName As Variant
Dim getElementsByClassName As Variant
Dim innerText As Variant
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
Dim cel As Variant, Text As Variant, Riga As Variant, UltimaRiga As Variant, Search As Variant, SearchRange As Variant, MyStr As Variant, MyStr2 As Variant, UpperCase As Variant, UpperCase2 As Variant
Dim Domanda As String, Domanda2 As String
Sub Previsioni_Meteo(ByVal myURL As String)
On Error GoTo finish
X = Foglio1.Range("D1").Value & ""
'Va Chiamata passandogli l'URL da leggere
myURL = "https://www.3bmeteo.com/meteo/" & X & ""
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
Set OggCol = IE.Document.getElementsByClassName("row") '- Localit� Me1teo
Set OggCol1 = IE.Document.getElementsByClassName("table") '(0).innerText '- Minima Attuale
Set OggCol2 = IE.Document.getElementsByClassName("table")
'Set OggCol4 = OggCol1(1).getElementsByTagName("glider-track")(0).innerText
With IE.element.getAttribute("table")
Sheets("Meteo").Range("B14").Value .getAttribute("=col-xs-1.2")(0).innerText
'Sheets("Meteo").Range("B11").Value = ("=col-xs-1-3 col-sm-3-5") & innerText
Sheets("Meteo").Cells(8, 2) = OggCol(0).innerText
Sheets("Meteo").Cells(13, 2) = OggCol2(0).innerText
End With
'Sheets("Meteo").Cells(13, 0) = OggCol(0).innerText
'���������������������������������������������������������������������������������
'For I = 1 To OggCol1.Length
'With Foglio1
'.Range("B30").Offset(I, 0) = OggCol3(I).getAttribute("src")
'End With
'Next I
'################################################################################
'X = Mid(Foglio1.Range("B13").Value, 70)
'Foglio1.Range("B9").Value = "" & X
'################################################################################
'Range("A11").VerticalAlignment = xlCenter
'Foglio1.Range("A:B").WrapText = True
'Foglio1.Range("A1").Select
'################################################################################
'Chiusura IE
'IE.Quit
Set IE = Nothing
Call Preleva_I_Dati_Dalla_Cella_web
'Call dividi
finish:
End Sub
Sub Preleva_I_Dati_Dalla_Cella_web()
'Contatore per la scrittura di parole trovate
Riga = 2
'Svuota l'ultima ricerca
UltimaRiga = ThisWorkbook.Worksheets("Meteo").Range("L1").End(xlDown).Row
If ThisWorkbook.Worksheets("Meteo").Range("L2") <> "" Then
ThisWorkbook.Worksheets("Meteo").Range("L2:L" & UltimaRiga).ClearContents
End If
Set Search = ThisWorkbook.Worksheets("Meteo").Range("K2:K100")
Set SearchRange = ThisWorkbook.Worksheets("Meteo").Range("B13")
For Each cel In SearchRange
For Each Text In Search
If InStr(cel, Text) Then
Debug.Print "Trovato " & Text & " alla cella " & cel.Address
'Scrivere le parole trovate
ThisWorkbook.Worksheets("Meteo").Range("L" & Riga).Value = Text
Riga = Riga + 1
End If
Next Text
Next cel
Call Rendi_La_Prima_Letta_In_Maiuscolo
End Sub
Sub Rendi_La_Prima_Letta_In_Maiuscolo()
'Domanda = InputBox("Inserire il Tuo Nome Grazie...!")
Domanda = Foglio1.Range("L2").Value
Domanda2 = Foglio1.Range("L3").Value
MyStr = Domanda
MyStr2 = Domanda2
UpperCase = Left(Domanda, 1)
UpperCase2 = Left(Domanda2, 1)
'Foglio1.Range("A3").Value = "Ciao"
Foglio1.Range("L2").Value = UCase(UpperCase) + Mid(Domanda, 2, 15)
Foglio1.Range("L3").Value = UCase(UpperCase2) + Mid(Domanda2, 2, 15)
Call Preleva_Solo_I_Dati_Interessati
End Sub
Sub Preleva_Solo_I_Dati_Interessati()
'Foglio1.Range("A6:C6").WrapText = True
With Foglio1
.Range("L2").Copy
.Range("B9").PasteSpecial
.Range("L3").Copy
.Range("B10").PasteSpecial
End With
'Foglio1.Range("B13").Select
'Foglio1.Range("B13").Clear
'Call Converti_In_Maiuscol_a_Prima_Lettera
End Sub
Sub Converti_In_Maiuscol_a_Prima_Lettera()
Dim Stringa, Parola
Dim Righe, R, Colonne
Dim Intervallo As Range
' prima fase: determino li'intervallo su cui lavorare
With Range("L2").Value
Righe = .Rows.Count
Colonne = .Columns.Count
Set Intervallo = .Resize(Righe, Colonne)
End With
If IsEmpty(Intervallo) Then
MsgBox "L'intervallo � vuoto"
Exit Sub
End If
' seconda fase: conversione delle stringhe mettendo in maiuscolo i soli primo caratteri
For R = 1 To Righe
Stringa = Intervallo(R, 1)
If Stringa <> "" Then
Parola = StrConv(Stringa, vbProperCase)
Intervallo(R, 1) = Parola
End If
Next
'Call Rimuovi_Il_Ritorno_A_Capo_Delle_Celle
End Sub
Sub Rimuovi_Il_Ritorno_A_Capo_Delle_Celle()
Dim Intervallo As Range
Application.ScreenUpdating = False
Application.Calculation = xlCalculationManual
For Each Intervallo In ActiveSheet.UsedRange
If 0 < InStr(Intervallo, Chr(10)) Then
Intervallo = Replace(Intervallo, Chr(10), "")
End If
Next
Application.ScreenUpdating = True
Application.Calculation = xlCalculationAutomatic
End Sub
Rispondi quotando
Originariamente inviata da A.Maurizio
