Sub Indirizzi_associazione() Dim IE As Object Dim Doc As Object Dim r As Integer Dim c As Integer Dim HTMLtr As Object Dim HTMLTable As Object Dim HTMLtd As Object Dim HTMLTables As Object Dim myURL As String Cells.Clear Set IE = CreateObject("InternetExplorer.Application") myURL = "https://www.agcom.it/numerazionicallcenter" With IE .Navigate myURL .Visible = True Do While .Busy: DoEvents: Loop Do While .ReadyState <> 4: DoEvents: Loop End With Set Doc = IE.Document Doc.getElementById("numerotelefono").Value = "0123456789" ' riesco inserirlo Doc.getElementById("filtro-submit").Click ' non da errore, mà non fa nulla MsgBox Doc.getElementById("num-risultati") MsgBox Doc.getElementById("odd") MsgBox 3 Stop '.... '.... IE.Quit Set IE = Nothing Set Doc = Nothing End Sub
Option Explicit Sub Telefoni_Agcom() Dim Ur As Long, x As Long, c As Long, Num As String Dim IE As Object Dim Doc As Object Dim HTMLtr As Object Dim HTMLTable As Object Dim HTMLtd As Object Dim HTMLTables As Object Dim oHTML_Element As IHTMLElement Const myURL As String = "https://www.agcom.it/numerazionicallcenter" Ur = Range("F" & Rows.Count).End(xlUp).Row Set IE = CreateObject("InternetExplorer.Application") For x = 2 To Ur c = 7 Num = Cells(x, 6) With IE .Navigate myURL '.Visible = True Do While .Busy: DoEvents: Loop Do While .ReadyState <> 4: DoEvents: Loop End With Set Doc = IE.Document Doc.getElementById("numerotelefono").Value = Num For Each oHTML_Element In Doc.getElementsByTagName("input") If oHTML_Element.Type = "submit" Then oHTML_Element.Click: Exit For ' circa 10 Each Next ''''''''''''''''''' Aggiunto perchè mi copiava il valore della ricerca precente With IE Do While .Busy: DoEvents: Loop Do While .ReadyState <> 4: DoEvents: Loop End With Set Doc = IE.Document ''''''''''''''''' Set HTMLTables = Doc.getElementsByClassName("tab-telefonia-fissa") For Each HTMLTable In HTMLTables ' qui salta se la ricerrca non da esito For Each HTMLtr In HTMLTable.getElementsByTagName("tr") For Each HTMLtd In HTMLtr.getElementsByTagName("td") Cells(x, c) = HTMLtd.innerText c = c + 1 Next HTMLtd Next HTMLtr Next HTMLTable If Cells(x, 7) = "" Then Cells(x, 7) = "Non esiste" Next IE.Quit MsgBox "Finito" ', fatto in " Set IE = Nothing Set Doc = Nothing End Sub