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