Nicht nur Namen aus Adressliste eintragen

Sub Adressen_eintragen()
Dim objRecipients As Outlook.AddressEntries
Dim lngCount As Long
Set myolApp = CreateObject("Outlook.Application")
Set myNamespace = myolApp.GetNamespace("MAPI")
Set myAddressList = myNamespace.AddressLists("Globale Adressliste")
Set myAddressEntries = myAddressList.AddressEntries
For lngCount = 1 To myAddressEntries.Count
With myAddressEntries.Item(lngCount)
Pos1 = InStr(1, .Name, "A")
If Pos1 > 0 Then
Dim iRow As Integer
iRow = Cells(Rows.Count, 1).End(xlUp).Row + 1
Cells(iRow, 1).Value = .Name
End If
End With
Next lngCount
Set myolApp = Nothing
Set myNamespace = Nothing
Set myAddressList = Nothing
Set myAddressEntries = Nothing
End Sub