|
naja, ich will mal nicht so sein. Die Addressen landen hier in Spalte B. Ich gehe davon aus das keine anderen Daten im Blatt sind. Was man nicht weis, kann man nicht berücksichtigen.
Sub namen()
Dim i As Long, x As Long, cnt As Long
Dim arr
Dim strAdr As String
Dim myAddresses As Object
Set myAddresses = CreateObject("Scripting.Dictionary")
i = 4 'startzeile
'Zellwerte zeilenweise aufteilen
Do While Cells(i, 1) <> ""
arr = Split(Cells(i, 1), ";")
Cells(i, 2).Resize(, UBound(arr) + 1) = arr
i = i + 1
Loop
'adressen umschreiben und in dictionary speichern
For x = 4 To i - 1
For cnt = 2 To UsedRange.SpecialCells(xlCellTypeLastCell).Column
If Cells(x, cnt).Value <> "" Then
strAdr = Replace(Trim(Cells(x, cnt).Value), " ", ".")
strAdr = strAdr & "@xy.com"
If Not myAddresses.Exists(strAdr) Then
myAddresses.Add strAdr, 1
End If
End If
Next cnt
Next x
' alternativ zu nachfolgenden Code myAddresses.Keys für den Mailversand verwenden
'adressen in Tabellenblatt schreiben
Range(Cells(4, 2), Cells(x, cnt)).ClearContents
Cells(4, 2).Resize(myAddresses.Count).Value = Application.Transpose(myAddresses.Keys)
Columns(2).AutoFit
End Sub
|