Modifica effettuata:data OK
Resta il fatto che non aggiorna.
Rimango sulla versione con IE che si chiude.
Come hai intuito, il testo importato contiene caratteri spuri (CR, nel nostro caso); li elimino all'interno della nuova Function GimmeVal usando la WorksheetFunction.Clean
Volevo chiederti se puoi inserire l'istruzione in questo codice relativo alla versione che ho deciso adottare.
Come ti scrissi ho risolto con una formula ma se si elimina col codice credo sia meglio.
- Codice: Seleziona tutto
#If VBA7 Then '!!! ON TOP OF THE VBA MODULE !!!!
Private Declare PtrSafe Sub Sleep Lib "kernel32" (ByVal dwMilliseconds As LongPtr)
#Else
Declare Sub Sleep Lib "kernel32" (ByVal dwMilliseconds As Long)
#End If
Sub DaReteMir()
Dim IE As Object, myURLb As String, myID As Object
Dim I As Long, skArr, myTim As Single, dSh As Worksheet
Dim ArrSk(1 To 3)
'
Set dSh = Sheets("ReteMir") '<<< Il foglio "parametri"
'
myURLb = "https://retemir.regione.marche.it/meteo/stazioni?codstaz="
Set IE = CreateObject("InternetExplorer.Application")
myTim = Timer
Debug.Print Format(Timer - myTim, "hh:mm:ss"), ">>>"
skArr = Array("Stazione", "Ultimo agg.", "Total Rain Today :", "Rain Intensity :", "Air Temperature :", "Relative Umidity :")
skArr1 = Array("Stazione", "Ultimo agg.", "Total Rain Todaly :", "Intensità Pioggia :", "Temperatura Aria :", "Umidità Relativa :")
skArr2 = Array("Stazione", "Ultimo agg.", "Pioggia TOT Oggi :", "Intensità di Pioggia :", "Temperatura Aria :", "Umidità Relativa :")
ArrSk(1) = skArr
ArrSk(2) = skArr1
ArrSk(3) = skArr2
For I = 5 To dSh.Cells(Rows.Count, "A").End(xlUp).Row
dSh.Cells(I, 2).Resize(1, 6).ClearContents
dSh.Cells(I, 2).Value = "##Cerca##"
If dSh.Cells(I, 1) <> "" Then
reVai:
With IE
Debug.Print Format(Timer - myTim, "0.00"), myURLb & dSh.Cells(I, "A")
.navigate myURLb & dSh.Cells(I, "A")
.Visible = True
'' Stop '*** VEDI Testo
Do While .Busy: DoEvents: Loop 'Attesa not busy
Do While .readyState <> 4: DoEvents: Loop 'Attesa documento
End With
'
myStart = Timer 'attesa addizionale
Sleep 18000
If IE.LocationURL = "https://retemir.regione.marche.it/login" Then
'eventuale Login:
Debug.Print Format(Timer - myTim, "0.00"), "Eseguo Login"
Set myID = IE.document.getElementById("loginform")
myID.getElementsByTagName("input")(0).Value = dSh.Range("B1").Value
myID.getElementsByTagName("input")(1).Value = dSh.Range("B2").Value
Sleep 100
IE.document.getElementById("btn-login-extended").Click
Sleep 3000
runlin = True
GoTo reVai
End If
Debug.Print Format(Timer - myTim, "0.00"), "Arrivato su: " & IE.LocationURL
If IE.LocationURL <> (myURLb & dSh.Cells(I, 1)) And runlin Then
MsgBox ("Destinazione non raggiunta, operazione terminata")
Debug.Print myURL, IE.LocationURL
GoTo ExitA
End If
'Importa dati di Stazione:
Set myColl = Nothing
For J = 1 To 10
Set myColl = IE.document.getElementsByClassName("leaflet-popup-content")
If myColl.Length > 0 Then Exit For
Sleep 200
Next J
Debug.Print Format(Timer - myTim, "0.00"), "Typename(myColl): " & TypeName(myColl)
Debug.Print " ", "Items in myColl: " & myColl.Length
Debug.Print " ", "Loop J=" & J
If myColl.Length > 0 Then
On Error Resume Next
Debug.Print Format(Timer - myTim, "0.00"), "Ubound(mySplit): " & UBound(mySplit)
dSh.Cells(4, 2).Resize(1, 6) = skArr
mySplit = Split(myColl(0).innerText, Chr(10), , vbTextCompare)
dSh.Cells(I, 2) = mySplit(1)
dSh.Cells(I, 3) = GimmeVal(ArrSk, 1, myColl(0).innerText)
dSh.Cells(I, 4) = GimmeVal(ArrSk, 2, myColl(0).innerText)
dSh.Cells(I, 5) = GimmeVal(ArrSk, 3, myColl(0).innerText)
dSh.Cells(I, 6) = GimmeVal(ArrSk, 4, myColl(0).innerText)
dSh.Cells(I, 7) = GimmeVal(ArrSk, 5, myColl(0).innerText)
On Error GoTo 0
End If
End If
Next I
'Chiudi IE e completa
Debug.Print Format(Timer - myTim, "0.00"), "Completato"
ExitA:
IE.Quit
Set IE = Nothing
End Sub
Function GimmeVal(ByRef ArrArr, ByVal iInd As Long, ByVal InnerT As String) As Variant
Dim myPos As Long, I As Long, UpTo As Long
If Len(InnerT) < 5 Then Exit Function
For I = 1 To 3
' Set larr = ArrArr(I)
myPos = InStr(1, InnerT, ArrArr(I)(iInd), vbTextCompare)
If myPos > 0 Then Exit For
Next I
If myPos = 0 Then Exit Function
UpTo = InStr(myPos, InnerT & Chr(10), Chr(10), vbTextCompare)
GimmeVal = Mid(InnerT, myPos + Len(ArrArr(I)(iInd)), UpTo - myPos - Len(ArrArr(I)(iInd)))
End Function
Altra cosa,importando altre stazioni anche da altri siti ,mi ritrovo a volte a dover intervenire sulla data visualizzata per me in modo non consono.
Non riesco a risolvere questo:
Mi appare col formato aaaa-mm-gg hh:mm:ss
2021-05-07 10:14:00
ma vorrei che mi apparisse con
gg/mm/aaaa hh:mm
Anche per quest'altro non riesco a risolvere,mi appare:
Stazione Frontino, Pian dei Prati alt. m. 780 - Dati aggiornati il 06/05/21 alle ore 21.01
cerco di estrapolare solo il formato gg/mm/aaaa hh:mm
con
=SOSTITUISCI(STRINGA.ESTRAI(A1;67;23);" alle ore ";"")*1
ma ottengo un errore #VALORE!
dove sbaglio?
Registrazione
)...
)
