Emailadressen Namen zuordnen

Thomas · 1970-01-01T00:00:00+00:00

Hallo! Gibt es die Möglichkeit folgendes per VBA zu lösen? Ich habe in Spalte A den Vorname, in Spalte B den Nachnamen und in Spalte C Emailadressen - soweit so gut, ALLERDINGS ist die Spalte C nicht den Spalten A/B zugeordnet wie muss der Code aussehen der überprüft ob ENTWEDER Vor- UND Nachname in der Emailadresse vorkommt - nicht zwangsläufig in der gleichen Reihenfolge! und die emailadresse aus Spalte C dann in der passenden (zu den Spalten A+B) Zeile der Spalte D ausgibt ODER Vorname - dann in Spalte E oder Nachname dann in Spalte F quasi - ein Zusammenfügen/Zusammensortieren der Namen zu den Emailadressen?

Hallo Thomas,
hier probier den mal
der Sucht aber nur nachnamen


Sub t1()
Dim v, n, fz, su As Variant
Dim l, i, dg As Integer
Dim en As Boolean
en = True
With ActiveSheet.Range("a2:AB2000")
Set az = .Find(what:="*", after:=.Range("A1"), LookIn:=xlValues, _
lookat:=xlWhole, searchdirection:=xlPrevious)
End With
l = az.Row
Set n = ActiveSheet.Range("b2", Range("b2").End(xlDown))
For dg = 1 To l - 1
For i = 1 To 2
If i = 1 Then
su = "*" & n(dg) & "*"
ElseIf i = 2 Then
On Error Resume Next
su = n(dg)
su = Replace(su, "ü", "ue")
su = Replace(su, "ö", "oe")
su = Replace(su, "ä", "ae")
su = "*" & su & "*"
End If
With ActiveSheet.Range("c2:c" & l)
Set fz = .Find(what:=su, after:=.Range("A1"), LookIn:=xlValues, _
lookat:=xlWhole, searchdirection:=xlNext)
If fz Is Nothing Then
GoTo ni
End If
erstadd = fz.Address
Do
Range("d" & dg + 1).Select
efc
ActiveCell = fz
Set fz = .FindNext(fz)
Loop While Not fz Is Nothing And fz.Address  erstadd
End With
ni:
Next i
Next dg
End Sub
Private Sub efc()
Do While ActiveCell  ""
ActiveCell.Offset(0, 1).Range("A1").Select
Loop
End Sub

Hallo Thomas
Hier der Code mit Färbung der bereits verteilten emailadd
hab auch noch einen Fehler behoben (add ohne umlaute hat er doppelt koppiert)
Einfach den kompletten code austauschen.
solle dir eine andere Farbe leiber sein kannst du einfach kurz ein Makro aufzeichnen und eine Zelle Färben.
aus diesem Code nimmst du dann die zeile .ThemeColor ="Feldfarbe als code " und tauschst diese in den Code hier aus
Viel Spaß damit
Dirk


Sub t1()
Dim v, n, fz, su As Variant
Dim l, i, dg, u1, u2, u3 As Integer
Dim en As Boolean
With ActiveSheet.Range("a2:AB2000")
Set az = .Find(what:="*", after:=.Range("A1"), LookIn:=xlValues, _
lookat:=xlWhole, searchdirection:=xlPrevious)
End With
l = az.Row
Set n = ActiveSheet.Range("b2", Range("b2").End(xlDown))
For dg = 1 To l - 1
u1 = 0
u2 = 0
u3 = 0
For i = 1 To 2
If i = 1 Then
su = "*" & n(dg) & "*"
ElseIf i = 2 Then
On Error Resume Next
su = n(dg)
u1 = InStrRev(su, "ü")
u2 = InStrRev(su, "ö")
u3 = InStrRev(su, "ä")
If u1 = 0 And u2 = 0 And u3 = 0 Then
MsgBox (su)
GoTo dgweiter
Else
su = Replace(su, "ü", "ue")
su = Replace(su, "ö", "oe")
su = Replace(su, "ä", "ae")
su = "*" & su & "*"
End If
End If
With ActiveSheet.Range("c2:c" & l)
Set fz = .Find(what:=su, after:=.Range("A1"), LookIn:=xlValues, _
lookat:=xlWhole, searchdirection:=xlNext)
If fz Is Nothing Then
GoTo ni
End If
erstadd = fz.Address
Do
With Range("c" & fz.Row).Interior
.ThemeColor = xlThemeColorAccent6
End With
Range("d" & dg + 1).Select
efc
ActiveCell = fz
Set fz = .FindNext(fz)
Loop While Not fz Is Nothing And fz.Address  erstadd
End With
ni:
Next i
dgweiter:
Next dg
End Sub
Private Sub efc()
Do While ActiveCell  ""
ActiveCell.Offset(0, 1).Range("A1").Select
Loop
End Sub

Vorname	Nachname	Emailadresse
Peter	Müller	Peter.Mueller@domain.com
Anna	Schmidt	Anna.Schmidt@domain.de
Max	Mustermann	Max.Mustermann@domain.org

Vorname	Nachname	Emailadresse	Treffer 1	Treffer 2	Treffer 3
Peter	Müller	Peter.Mueller@domain.com	Peter.Mueller@...	Peter.Mueller@...	...
Anna	Schmidt	Anna.Schmidt@domain.de	Anna.Schmidt@...	...	...

Forumthread: Emailadressen Namen zuordnen

6
Beiträge zum Forumthread

Beiträge zu diesem Forumthread

Forumthreads zu verwandten Themen

Infobox / Tutorial

Emailadressen den Namen zuordnen in Excel

Schritt-für-Schritt-Anleitung

Häufige Fehler und Lösungen

Alternative Methoden

Praktische Beispiele

Tipps für Profis

FAQ: Häufige Fragen

Beliebteste Forumthreads (12 Monate)