Exel Formeln

[Jörg Lorenz]

Hi Chrischan,

Ich möchte nun, dass Exel mir alle E-Mail-Adressen die ein "@gmx." beinhalten in EIN EIZELNES neues Feld setzt und zwischen jedem Eintrag ein Komma setzt, sodass das ganze letztendlich so aussieht:

[e-mail], [e-mail], [e-mail], ... usw.

wenn Du Dich etwas mit VBA auskennst, kannst Du diesen Code verwenden, den Du natürlich anpassen musst:

'Die Routine sucht in einer Spalte nach Bestandteilen von Mailadressen und
'fasst die gefundenen Adressen in einem String zusammen.

Sub AdressenZUsammenFassen()
Dim strSuchstring As String, strTrenner As String
Dim strAdresse As String, strErsteZelle As String
Dim strErgebnisZelle As String
Dim strGesamt As String
Dim intSpalte As Integer
Dim objGefunden As Object
Dim lngI As Long
Dim arrGesamt()

'Hier anpassen: ------------------------------------------------------------------------------
strSuchstring = "@gmx.de"   'Bestandteil, der in den zu suchenden Adressen enthalten sein soll
intSpalte = 1               'Spalte, in der gesucht werden soll
strTrenner = ","            'Zeichen, durch das die gefundenen Adressen getrennt sein sollen
strErgebnisZelle = "B1"     'Zelle, in der das Ergebnis ausgegeben werden soll
'---------------------------------------------------------------------------------------------

lngI = 0
Set objGefunden = ActiveSheet.Columns(intSpalte).Find(strSuchstring, lookat:=xlPart)
If Not objGefunden Is Nothing Then
    lngI = lngI + 1: ReDim Preserve arrGesamt(lngI): arrGesamt(lngI - 1) = Range(objGefunden.Address)
    strErsteZelle = objGefunden.Address(False, False)
    strAdresse = strErsteZelle
Else
    Exit Sub
End If
Do
    Set objGefunden = ActiveSheet.Columns(intSpalte).Find(strSuchstring, after:=Range(strAdresse), lookat:=xlPart)
    strAdresse = objGefunden.Address(False, False)
    If strAdresse = strErsteZelle Then Exit Do
    lngI = lngI + 1: ReDim Preserve arrGesamt(lngI): arrGesamt(lngI - 1) = Range(objGefunden.Address)
Loop
For lngI = 0 To UBound(arrGesamt) - 1
    If lngI < UBound(arrGesamt) - 1 Then strGesamt = strGesamt & arrGesamt(lngI) & strTrenner Else strGesamt = strGesamt & arrGesamt(lngI)
Next
Range(strErgebnisZelle) = strGesamt
End Sub

Ich habe Dir mal eine Beispieldatei hochgeladen: http://www.excel-vba.de/temp/adressensammler.zip

Viele Grüße

Jörg