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
Do
While
Cells(i, 1) <>
""
arr = Split(Cells(i, 1),
";"
)
Cells(i, 2).Resize(, UBound(arr) + 1) = arr
i = i + 1
Loop
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
Range(Cells(4, 2), Cells(x, cnt)).ClearContents
Cells(4, 2).Resize(myAddresses.Count).Value = Application.Transpose(myAddresses.Keys)
Columns(2).AutoFit
End
Sub