Thema Datum  Von Nutzer Rating
Antwort
05.06.2024 09:55:15 Mhussah
NotSolved
Blau Emailadressen anhand der Namen rausfinden
06.06.2024 10:59:30 Gast76719
NotSolved

Ansicht des Beitrags:
Von:
Gast76719
Datum:
06.06.2024 10:59:30
Views:
55
Rating: Antwort:
  Ja
Thema:
Emailadressen anhand der Namen rausfinden

Hier mal ein Script das funktioniert:

Sub GetEmailAddresses()
    Dim olApp As Object
    Dim olNamespace As Object
    Dim olContacts As Object
    Dim olContact As Object
    Dim ws As Worksheet
    Dim lastRow As Long
    Dim i As Long
    Dim name As String
    Dim emailAddress As String
    Dim nameParts() As String
    Dim searchName1 As String
    Dim searchName2 As String

    ' Set worksheet
    Set ws = ActiveSheet ' Anpassung an den tatsächlichen Blattnamen

    ' Initialize Outlook objects
    Set olApp = CreateObject("Outlook.Application")
    Set olNamespace = olApp.GetNamespace("MAPI")
    Set olContacts = olNamespace.GetDefaultFolder(10).Items ' 10 steht für olFolderContacts

    ' Find the last row with data in column A
    lastRow = ws.Cells(ws.Rows.Count, "A").End(xlUp).Row

    ' Loop through each name in column A
    For i = 1 To lastRow
        name = ws.Cells(i, 1).Value
        emailAddress = ""
        
        ' Split the name into parts
        nameParts = Split(name, " ")
        
        ' Create search patterns for "Name Vorname" and "Vorname Name"
        If UBound(nameParts) = 1 Then
            searchName1 = nameParts(0) & " " & nameParts(1)
            searchName2 = nameParts(1) & " " & nameParts(0)
        Else
            searchName1 = name
            searchName2 = name
        End If

        ' Search for the contact in Outlook
        For Each olContact In olContacts
            If InStr(1, olContact.FullName, searchName1, vbTextCompare) > 0 Or InStr(1, olContact.FullName, searchName2, vbTextCompare) > 0 Then
                emailAddress = olContact.Email1Address
                Exit For
            End If
        Next olContact

        ' Write the email address to column B
        ws.Cells(i, 2).Value = emailAddress
    Next i

    ' Cleanup
    Set olContact = Nothing
    Set olContacts = Nothing
    Set olNamespace = Nothing
    Set olApp = Nothing
End Sub

 


Ihre Antwort
  • Bitte beschreiben Sie Ihr Problem möglichst ausführlich. (Wichtige Info z.B.: Office Version, Betriebssystem, Wo genau kommen Sie nicht weiter)
  • Bitte helfen Sie ebenfalls wenn Ihnen geholfen werden konnte und markieren Sie Ihre Anfrage als erledigt (Klick auf Häckchen)
  • Bei Crossposting, entsprechende Links auf andere Forenbeiträge beifügen / nachtragen
  • Codeschnipsel am besten über den Code-Button im Text-Editor einfügen
  • Die Angabe der Emailadresse ist freiwillig und wird nur verwendet, um Sie bei Antworten auf Ihren Beitrag zu benachrichtigen
Thema: Name: Email:

 
 

  • Bitte beschreiben Sie Ihr Problem möglichst ausführlich. (Wichtige Info z.B.: Office Version, Betriebssystem, Wo genau kommen Sie nicht weiter)
  • Bitte helfen Sie ebenfalls wenn Ihnen geholfen werden konnte und markieren Sie Ihre Anfrage als erledigt (Klick auf Häckchen)
  • Bei Crossposting, entsprechende Links auf andere Forenbeiträge beifügen / nachtragen
  • Codeschnipsel am besten über den Code-Button im Text-Editor einfügen
  • Die Angabe der Emailadresse ist freiwillig und wird nur verwendet, um Sie bei Antworten auf Ihren Beitrag zu benachrichtigen

Thema Datum  Von Nutzer Rating
Antwort
05.06.2024 09:55:15 Mhussah
NotSolved
Blau Emailadressen anhand der Namen rausfinden
06.06.2024 10:59:30 Gast76719
NotSolved