AW: in Excel nur Emailadresse auslesen und kopieren
10.04.2019 13:31:40
Nepumuk
Hallo Heidi,
so ok?
Option Explicit
Public Sub CopyMailAddress()
Dim objCell As Range
Dim strFirstAddress As String, astrMailAddress() As String
Dim lngRow As Long, ialngIndex As Long
Worksheets("Tabelle2").Columns(1).ClearContents
With Worksheets("Tabelle1").Cells
Set objCell = .Find(What:="@", LookIn:=xlValues, _
LookAt:=xlPart, MatchCase:=False)
If Not objCell Is Nothing Then
strFirstAddress = objCell.Address
Do
astrMailAddress = GetMailAddress(strText:=objCell.Text)
For ialngIndex = LBound(astrMailAddress) To UBound(astrMailAddress)
lngRow = lngRow + 1
Worksheets("Tabelle2").Cells(lngRow, 1).Value = astrMailAddress(ialngIndex)
Next
Set objCell = .FindNext(After:=objCell)
Loop Until objCell.Address = strFirstAddress
Set objCell = Nothing
End If
End With
Call Worksheets("Tabelle2").Columns(1).RemoveDuplicates(Columns:=1, Header:=xlNo)
End Sub
Private Function GetMailAddress(ByVal strText As String) As String()
Dim objRegEx As Object, objMatch As Object
Dim astrTemp() As String
Dim ialngIndex As Long
Set objRegEx = CreateObject("VBScript.RegExp")
With objRegEx
.Global = True
.Pattern = "[a-z0-9\-\.]{2,63}@[a-z0-9\-\.]{2,63}\.[a-z]{2,4}"
.IgnoreCase = True
Set objMatch = .Execute(strText)
End With
Redim astrTemp(0 To objMatch.Count - 1)
For ialngIndex = 0 To objMatch.Count - 1
astrTemp(ialngIndex) = objMatch.Item(ialngIndex).Value
Next
GetMailAddress = astrTemp
Set objRegEx = Nothing
Set objMatch = Nothing
End Function
Gruß
Nepumuk