Ecco il codice che ho elaborato e che permette di avere ben 3 colonne dove memorizzare gli indirizzi email dei Comuni trovati nel sito http://italia.indettaglio.it/ita/email/email.html
Ovviamente bisogna creare un file di excel con due fogli, il primo chiamato comuni, ed il secondo chiamato macro
Nel foglio comuni avremmo le colonne disposte come segue nello schema sottostante (ovviamente i campi email saranno vuoti), nella colonna F del foglio Comuni occorre inserire i codici Istat dei Comuni per cui si vogliono le Email.
Un elenco di Codici Istat è reperibile al seguente indirizzo : http://www.istat.it/storage/codici-unita-amministrative/Archivio-elenco-comuni-codici-e-denominazioni_Anni-2014_2017.zip
Comune | Email1 | Email2 | Email3 | ISTAT | ISTAT | ISTATURL | Provincia |
Abano Terme | abanoterme.pd@cert.ip-veneto.net | abanoterme.pd@cert.ip-veneto.net | consorziobpa@pec.it | 28001 | 028001 | 028/001 | Padova |
Abbadia Cerreto | info@comune.abbadiacerreto.lo.it | comune.abbadiacerreto@pec.regione.lombardia.it | 98001 | 098001 | 098/001 | Lodi | |
Abbadia Lariana | segretario@comune.abbadia-lariana.lc.it | comune.abbadialariana@legalmail.it | 97001 | 097001 | 097/001 | Lecco | |
Abbadia San Salvatore | sindaco@comune.abbadia.siena.it | comune.abbadia@postacert.toscana.it | 52001 | 052001 | 052/001 | Siena | |
Abbasanta | segreteria@comune.abbasanta.or.it | demografico@pec.comune.abbasanta.or.it | protocollo@pec.comune.abbasanta.or.it | 95001 | 095001 | 095/001 | Oristano |
'modificato da me per fare 3 colonne di email Public riga, righe As Integer Sub Email_Extractor_From_Italia_in_Dettaglio() Dim oWebData As Object, sPageHTML As String, sWebURL As String 'conto le righe nel foglio e le memorizzo in variabile RIGHE righe = Sheets("comuni").UsedRange.Rows.Count 'parto dalla riga due in quanto nella 1 ci sono le intestazioni di colonna che non mi interessano riga = Sheets("macro").Range("B2").Value If riga = "" Then riga = 2 'ripeto n volte quanto sono le righe nel foglio di excel Do Until riga > righe valoreCella = Sheets("comuni").Range("B" & riga).Value If (valoreCella = "") Then 'formo il codice istat da usare nella query web codiceistat = Sheets("comuni").Range("F" & riga).Value sWebURL = "http://italia.indettaglio.it/ita/email/email_out.html?id_comune=" & codiceistat 'Extract data from website to Excel using VBA Set oWebData = CreateObject("MSXML2.ServerXMLHTTP") oWebData.Open "GET", sWebURL, False oWebData.send sPageHTML = oWebData.responseText 'Get webpage data into Excel Extract_Email_Address_From_Text sPageHTML 'verificare End If riga = riga + 1 Loop End Sub '''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''' ' Visit our website for more Tips and Tricks ' ---- Officetricks.com ---- ' '''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''' Sub Extract_Email_Address_From_Text(Optional Text_Content As String) Dlim_List = " ""(),:;<>@[\]" Dim conta_email As Integer 'riga = 2 conta_email = 0 'Get Text Content and assign to a Variable If Text_Content = "" Then Text_Content = ThisWorkbook.Sheets(1).Cells(2, 1) End If Web_Page_Text1 = Text_Content If Web_Page_Text1 = "" Then MsgBox "Error: No Input Provided - Provide Input" Exit Sub End If 'Scan each word in Text and Extract Email Addresses orow = 2 While (Web_Page_Text1 <> "") 'Locate position of symbol "@" First_@ = VBA.InStr(1, Web_Page_Text1, "@", vbTextCompare) 'If there is no occurance of "@" then terminate process If First_@ = 0 Then GoTo End_sub: 'Seperate Web_Page_Text2 = VBA.Mid(Web_Page_Text1, 1, First_@ - 1) Web_Page_Text3 = VBA.Mid(Web_Page_Text1, First_@ + 1) Dlim_Pos_Max = 99999 Dlim_Pos_Min = 0 For i = 1 To VBA.Len(Dlim_List) Dlim_2_Compare = VBA.Mid(Dlim_List, i, 1) Dlim_Pos = VBA.InStrRev(Web_Page_Text2, Dlim_2_Compare, -1, vbTextCompare) If (Dlim_Pos > Dlim_Pos_Min) And (Dlim_Pos > 0) Then Dlim_Pos_Min = Dlim_Pos Dlim_Pos = VBA.InStr(1, Web_Page_Text3, Dlim_2_Compare, vbTextCompare) If (Dlim_Pos < Dlim_Pos_Max) And (Dlim_Pos > 0) Then Dlim_Pos_Max = Dlim_Pos Next i If Dlim_Pos_Max = 0 Then GoTo End_sub: 'get Email list to Text Variable Email_Domain_Part = VBA.Mid(Web_Page_Text3, 1, Dlim_Pos_Max - 1) Email_Local_Part = VBA.Mid(Web_Page_Text2, Dlim_Pos_Min + 1, VBA.Len(Web_Page_Text2) - Dlim_Pos_Min) Mail_Address = Email_Local_Part & "@" & Email_Domain_Part ' se l'indirizzo email rilevato contiene italia.indettaglio.it allora non deve usarlo e deve cercarne un altro If Email_Domain_Part = "italia.indettaglio.it" Or InStr(Mail_Address, "@media") Then Mail_Address = "" GoTo fine End If 'scrive la mail nel file id excel conta_email = conta_email + 1 'ThisWorkbook.Sheets(comuni).Cells(orow, conta_email).Select 'ThisWorkbook.Sheets(comuni).Cells(orow, conta_email + 2) = Mail_Address If conta_email = 1 Then Sheets("comuni").Range("B" & riga).Value = Mail_Address End If If conta_email = 2 Then Sheets("comuni").Range("C" & riga).Value = Mail_Address End If If conta_email = 3 Then Sheets("comuni").Range("D" & riga).Value = Mail_Address GoTo End_sub End If 'se trova piu di tre indirizzi email, termina la ricerca e passa al prossimo comune 'If conta_email > 3 Then GoTo End_sub fine: 'Scan through remaining content orow = orow + 1 Web_Page_Text1 = VBA.Mid(Web_Page_Text1, Dlim_Pos_Max + First_@ + 1) Wend End_sub: 'riga = riga + 1 'MsgBox " Process Completed" End Sub
E per la felicità dei più pigri … eccovi il file
6 commenti
Davide · 30/05/2017 alle 6:55 am
Non funziona trova solo la mail sindaco@comune.roma.it
admin · 30/05/2017 alle 4:47 pm
Buongiorno, è diverso tempo che non lo uso, ma quando lo feci funzionò molto bene estraendo tutte le email di cui avevo bisogno.
Può essere che la struttura del sito sia cambiata o che abbiano implementato un controllo sugli accessi al sito o chissà quale altro problema.
Il suo problema è solo con il Comune di Roma o con tutti i Comuni?
admin · 30/05/2017 alle 6:53 pm
Nella colonna F del foglio Comuni occorre inserire per ogni riga il codice Istat del Comune per cui si vogliono gli indirizzi email.
L’elenco dei Codici Istat è reperibile al seguente link :
admin · 22/11/2017 alle 3:34 am
Confermo…il sito ha cambiato struttura ed il codice non riesce più a reperire le informazioni.
Se necessita ho il file con tutte le mail estrapolate.
Fabio · 14/12/2017 alle 5:59 pm
Buonasera Marco,
sarebbe possibile per Lei condividere il database delle email estrapolate?
Grazie in anticipo, in ogni caso.
Saluti
admin · 14/05/2020 alle 9:07 am
Buonguiorno, perdoni il ritardo. Dovrebbe essere presente nel sito il file excel. Non ne ho copia essendo passato diverso tempo. Ricordo che misi un link nell’articolo che permetteva il download.