Microsoft Excel

Herbers Excel/VBA-Archiv

Informationen und Beispiele zum Thema MsgBox
BildScreenshot zu MsgBox MsgBox-Seite mit Beispielarbeitsmappe aufrufen

Emailadressen Namen zuordnen | Herbers Excel-Forum


Betrifft: Emailadressen Namen zuordnen von: Thomas Windbüchler
Geschrieben am: 26.01.2012 13:47:08

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?

  

Betrifft: AW: Emailadressen Namen zuordnen von: Dirk
Geschrieben am: 26.01.2012 16:35:09

Hallo Thomas,

bei deiner Aufgabenstellung gibt es x Fehlermöglichkeiten.

Hier mal ein paar Beispiele
Häufig verwendete Nachnamen (im schlimmsten Fall auch noch Vorname)
Umlaute (meines wissens nach sind mitlerweile umlaute in Emailadd erlaubt)

um das Ganze mal Bildlicher zu machen
Häufige e-Mail syntax für z.b. Peter Müller
Peter.Müller@ , Peter.Mueller@ *1
P.Müller@, P.Mueller@ *2
Müller@, Mueller@ *3

*1 sowie Peter als auch Müller sind häufig verwendete Namen (meherer Treffermöglichkeiten)
*2 Müller gibt es viele und Vornamen mit P ebenfalls
*3 schlimmstfall

Gibt es jeden Nachnamen bei dir nur ein mal kein Problem
Ansonsten wirds schon kritisch

Gruß
Dirk


  

Betrifft: AW: Emailadressen Namen zuordnen von: Thomas Windbüchler
Geschrieben am: 26.01.2012 17:03:00

Hallo Dirk!

Du hast die Problematik gut zusammengefasst, ich hätts nicht treffender machen können, also ja ist mir genau das bewusst, aber deswegen ja auch die VBA-Lösungssuche da es manuell natürlich auch geht (ca. 500 Emailadressen) aber eben sehr lange dauert?

Die idee war, dass alle "möglichen" gefunden emailadressen in den Spalten nach Rechts aufgelistet werden, um bei Deinem Beispiel zu bleiben

in D3 den Treffer zu Peter Müller der heisst Peter.Meier@beispiel.de
in E3 den Treffer zu Peter Müller der heisst Hans.Müller@aon.de
in F3 den Treffer zu Peter Müller der heisst Max.mueller@beispiel2.de
in G3 den Treffer zu Peter Müller der heisst peterm@beispiel3.de

usw. - und ja ich weiss die Möglichkeiten sind SEHR vielfältig...

Ich möchte in dem Fall die Liste der automatisch in outlook gespeicherten Emailadressen (jedesmal wenn Du an jemand schreibst...) meinem synchronisierten Handy-Kontakten im Outlook zuordnen, und ich dachte die Frage hat sicherlich schon jemand gehabt... scheint nicht so zu sein, oder?

vielleicht findet sich noch jemand der ein Makro ein paar Schleifen laufen lässt....

danke jedenfalls fürs mitdenken!

lg Thomas


  

Betrifft: AW: Emailadressen Namen zuordnen von: Dirk
Geschrieben am: 26.01.2012 22:10:20

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





  

Betrifft: Tabellenblätter erstellen mit Makro danach einlese von: Thomas Windbüchler
Geschrieben am: 27.01.2012 10:39:55

Hallo Dirk!

Ich bin begeistert! Vielleicht ist es sogar besser "nur" nach dem Nachnamen zu suchen? Jedenfalls ist das Ergebnis sensationell - unter Berücksichtigung der Schwierigkeiten dahinter.
Die "falsch" zugeordneten Emailadresse zuzuordnen ist jetzt viel viel weniger Arbeit als alle mühsam herauszusuchen.
Also vielen vielen Dank! - und ich kann das Makro immer wieder laufen lassen sobald sich die Liste wieder füllt....

Eine Funktion wäre noch super - am Ende des Makros, kann man dann alle "bereits" zugeordenten - wenn auch falsch zugeordneten - emailadressen mit einer Hintergrundfarbe (z.B. Orange) markieren, dann kann ich danach noch Manuell nach Farben filtern und habe alle die das Makro nicht zuordnen konnte in einer Liste?

also prüfen ob die Emailadresse in C? irgendwo in den Spalten D bis ? vorkommt und falls ja diese dann mit der Farbe markieren

aber schon jetzt - SENSATIONELL!!!!

lg Thomas


  

Betrifft: AW: Tabellenblätter erstellen mit Makro danach einlese von: Dirk
Geschrieben am: 27.01.2012 15:55:32

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



  

Betrifft: Tabellenblätter erstellen mit Makro danach einlese von: Thomas Windbüchler
Geschrieben am: 27.01.2012 22:57:46

Hallo Dirk!

Sensationell, vielen vielen Dank nochmals!

lg Thomas


Beiträge aus den Excel-Beispielen zum Thema "Emailadressen Namen zuordnen"