du hast also schon Code zusammengetragen, aber zeigst den hier nicht  weil?

wie dem auch sei, Chatgpt gibt mir das zurück. mit folgendem Hinweis 

+++++++++++++VBA-Makro: Termin erstellen + Kontakt aus Adressbuch auswählen +++++++++

Voraussetzungen / Hinweise

• Stelle sicher, dass dein Outlook-Kontakteordner als "Kontakte" benannt ist. Falls du z.?B. in einem anderen Ordner arbeitest (z.?B. "Privatkontakte"), musst du AddressLists("Kontakte") entsprechend anpassen.

• Der Dialog verwendet Outlooks eingebauten Kontaktauswahldialog, der auch in neuen E-Mails genutzt wird.

?Möchtest du zusätzlich:

• mehrere Kontakte auswählen und z.?B. als Teilnehmer einladen?

• automatisch den Termin in einen bestimmten Kalender speichern?

Sub TerminMitKontaktAuswaehlen()
    Dim olApp As Outlook.Application
    Dim olNS As Outlook.Namespace
    Dim olDlg As Outlook.SelectNamesDialog
    Dim olAddrList As Outlook.AddressList
    Dim olRecipients As Outlook.Recipients
    Dim olRecipient As Outlook.Recipient
    Dim olContact As Outlook.ContactItem
    Dim olAppt As Outlook.AppointmentItem
    
    Set olApp = Outlook.Application
    Set olNS = olApp.GetNamespace("MAPI")
    
    ' Dialog zur Kontaktauswahl öffnen
    Set olDlg = olApp.Session.GetSelectNamesDialog
    Set olAddrList = olNS.AddressLists("Kontakte") ' Lokale Kontakte
    If olAddrList Is Nothing Then
        MsgBox "Kein Kontakte-Adressbuch gefunden.", vbCritical
        Exit Sub
    End If
    
    With olDlg
        .AllowMultipleSelection = False
        .InitialAddressList = olAddrList
        .ShowOnlyInitialAddressList = True
        
        If .Display Then ' Wenn ein Kontakt ausgewählt wurde
            Set olRecipients = .Recipients
            If olRecipients.Count > 0 Then
                Set olRecipient = olRecipients.Item(1)
                
                ' Kontaktobjekt auflösen
                If olRecipient.Resolve Then
                    ' Kontakt abrufen, falls im lokalen Kontakteordner
                    On Error Resume Next
                    Set olContact = olNS.GetItemFromID(olRecipient.EntryID)
                    On Error GoTo 0
                    
                    If Not olContact Is Nothing Then
                        ' Termin erstellen und Kontaktinformationen einfügen
                        Set olAppt = olApp.CreateItem(olAppointmentItem)
                        With olAppt
                            .Subject = "Termin mit " & olContact.FullName
                            .Body = "Kontaktinformationen:" & vbCrLf & _
                                    "Name: " & olContact.FullName & vbCrLf & _
                                    "E-Mail: " & olContact.Email1Address & vbCrLf & _
                                    "Telefon: " & olContact.BusinessTelephoneNumber & vbCrLf & _
                                    "Firma: " & olContact.CompanyName
                            .Start = Now + 1
                            .Duration = 60
                            .Display
                        End With
                    Else
                        MsgBox "Kontakt konnte nicht geladen werden.", vbExclamation
                    End If
                Else
                    MsgBox "Empfänger konnte nicht aufgelöst werden.", vbExclamation
                End If
            End If
        Else
            MsgBox "Kein Kontakt ausgewählt.", vbInformation
        End If
    End With
End Sub