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 :

  • http://www.istat.it/storage/codici-unita-amministrative/Archivio-elenco-comuni-codici-e-denominazioni_Anni-2014_2017.zip
  • 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.

Lascia un commento