Kontakte von Excel nach Outlook (2. Versuch)

Sub Send_Contact_List()
(c) Ramses
Dim qWks As Worksheet, i As Integer
Dim MyOutApp As Object, MyOutCon As Object
'Wo stehen die Kontaktdaten
Set qWks = Worksheets("Kontakte")
'Outlook Objekt erstellen
Set MyOutApp = CreateObject("Outlook.Application")
'Mit "With" wird auf das Tabellenobjekt referenziert
Sheets("Kontakte").Select
With qWks
'Zählschleife starten
'Dazu wird der letzten Eintrag in Spalte A bestimmt
'Der Adressenbereich beginn in Zeile 1
'deshalb startet auch die Zählschleife dort
For i = 1 To Range("b65536").End(xlUp).Row
'Outlook Kontaktobject erstellen
Set MyOutCon = MyOutApp.CreateItem(2)
'Eine vollständige Liste der möglichen Felder
'finden Sie in der Outlook-VBA-Hilfe
With MyOutCon
.FirstName = Cells(i, 2).Value
.LastName = Cells(i, 1).Offset(0, 2).Value
.BusinessAddressStreet = Cells(i, 1).Offset(0, 3).Value
.BusinessAddressPostalCode = Cells(i, 1).Offset(0, 4).Value
.BusinessAddressCity = Cells(i, 1).Offset(0, 5).Value
.BusinessAddressCountry = Cells(i, 1).Offset(0, 6).Value
.BusinessAddressState = Cells(i, 1).Offset(0, 7).Value
.Email1Address = Cells(i, 1).Offset(0, 8).Value
.Save
End With
'Object entfernen
Set MyOutCon = Nothing
Next i
End With
Set MyOutApp = Nothing
End Sub