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
Nessun commento:
Posta un commento