lunedì 21 luglio 2014

Scrive elenco email controlla indirizzi

Attribute VB_Name = "Scrive_eleno_email_controlla"

'

Option Explicit

'

'

' vba - scrive in un file di testo gli indirizzi email presenti nel foglio

' ci sono tre colonne che contengono indirizzi email

' toglie gli indirizzi dupulicati.

' esclude i nominativi presenti nel foglio esclusi.

'

Sub ScriviEmailFoglioClientiTogleEsclusi()

Dim quanterighe, contarighe, foglio

Dim testo, contali, contocliente, posizione2, nomefoglio

Dim emailcommerciale, emailamministrazione, altraemail, colonnaconto

nomefoglio = "lista"

Set foglio = Sheets(nomefoglio)

'

quanterighe = Range(foglio.UsedRange.Cells(foglio.UsedRange.Rows.Count, 1).Address).Row

'

colonnaconto = "A" ' colonna con il conto cliente

contarighe = 1

testo = ""

contali = 0

While contarighe <= quanterighe

contocliente = foglio.Cells(contarighe, colonnaconto).Value

emailcommerciale = CStr(Trim(foglio.Cells(contarighe, "C").Value))

emailamministrazione = CStr(Trim(foglio.Cells(contarighe, "D").Value))

altraemail = CStr(Trim(foglio.Cells(contarighe, "E").Value))

If Len(emailcommerciale) = 0 Then

emailcommerciale = emailamministrazione

End If

posizione2 = Application.Match(contocliente, Worksheets("esclusi").Range("A:A"), 0)

If IsError(posizione2) Then

' MsgBox "Not Found"

testo = testo & estraiEmail(CStr(Trim(emailcommerciale))) ' email

testo = testo & estraiEmail(CStr(Trim(altraemail))) ' email

contali = contali + 1

Else

' MsgBox "Found"

End If

'

contarighe = contarighe + 1

Wend

' === il tuo indirizzo email

testo = testo & " indirizzo @ dominio . it - com ;"

'

' === elminani indirizzi email duplicati

testo = trovaunici(testo, ";")

'

' === scrivi risultato in file di testo

Dim fs, a

Set fs = CreateObject("Scripting.FileSystemObject")

Set a = fs.CreateTextFile("C:\" & nomefoglio & ".txt", True)

a.WriteLine (testo)

a.Close

'

'

End Sub

'

'

' === vba. verifica che il testo passato sia un indirizzo email.

'

Function estraiEmail(text As String) As String



Dim result As String, i, j

Dim allMatches As Object

Dim RE As Object

Set RE = CreateObject("vbscript.regexp")



'RE.Pattern = "^\b[A-Z0-9._%+-]+@[A-Z0-9.-]+\.[A-Z]{2,4}\b$"

RE.Pattern = "[A-Z0-9._%+-]+@[A-Z0-9.-]+\.[A-Z]{2,4}"

RE.Global = True

RE.IgnoreCase = True

Set allMatches = RE.Execute(text)

'

result = ""

'

For i = 0 To allMatches.Count - 1

result = result & allMatches.Item(i) & "; "

Next

'

estraiEmail = result

'

End Function

'

'

' vba. toglie gli indirizzi duplicati.

'

Function trovaunici(pvalori, separatore)

Dim valori, contali, quanti, valore, dizionario

valori = Split(pvalori, separatore)

quanti = UBound(valori)

Set dizionario = CreateObject("Scripting.Dictionary")

dizionario.CompareMode = vbTextCompare

For contali = 0 To quanti

valore = valori(contali)

If (dizionario.Exists(valore) = False) Then

dizionario.Add valore, True

End If

Next contali

'

Dim trovati, trovato, testo

trovati = dizionario.Keys

testo = ""

'

For Each trovato In trovati

testo = testo & trovato & "; "

Next

'

trovaunici = testo

'

End Function