Einfügen in neuem Tabellenblatt

Private Sub CommandButton13_Click()
'Excel-Sheet "Outlook Kontakte" öffnen
Sheets("Outlook Kontakte").Select
'Deklaration
Dim outApp As Object
Dim outNameSpace As Object
Dim outMapiFolder As Object
Dim outAllItems As Object
Dim outRealItems As Object
Dim outContactItem As Object
Dim strContactFilter As String
Dim Zeile As Integer
Zeile = 14
'Outlook-Objekte öffnen
Set outApp = CreateObject("Outlook.Application")
Set outNameSpace = outApp.GetNamespace("MAPI")
Set outMapiFolder = outNameSpace.GetDefaultFolder(10)
Set outAllItems = outMapiFolder.Items
'Verteilerlisten herausfiltern,'nur 'Richtige Kontakte' verwenden
strContactFilter = "[MessageClass] = 'IPM.Contact'"
Set outRealItems = outAllItems.Restrict(strContactFilter)
'Outlook-Kontakte ins Excel Tabellenblatt "Outlook-Kontakte" übertragen
For Each outContactItem In outRealItems
Cells(Zeile, 1).Value = outContactItem.Title
Cells(Zeile, 2).Value = outContactItem.FirstName
Cells(Zeile, 3).Value = outContactItem.LastName
Cells(Zeile, 4).Value = outContactItem.JobTitle
Cells(Zeile, 5).Value = outContactItem.Department
Cells(Zeile, 6).Value = outContactItem.CompanyName
Cells(Zeile, 8).Value = outContactItem.BusinessAddressStreet
Cells(Zeile, 9).Value = outContactItem.BusinessAddressPostalCode
Cells(Zeile, 10).Value = outContactItem.BusinessAddressCity
Cells(Zeile, 11).Value = outContactItem.BusinessAddressCountry
Cells(Zeile, 12).Value = outContactItem.BusinessTelephoneNumber
Cells(Zeile, 14).Value = outContactItem.HomeTelephoneNumber
Cells(Zeile, 15).Value = outContactItem.Email1Address
Cells(Zeile, 17).Value = outContactItem.WebPage
Zeile = Zeile + 1
Next outContactItem
MsgBox ("Die Datensätze wurden in das Tabellenblatt Outlook-Kontakte übertragen") 'MessageBox    _
_
_
anzeigen
'Speicher freigeben
Set outRealItems = Nothing
Set outAllItems = Nothing
Set outMapiFolder = Nothing
Set outNameSpace = Nothing
Set outApp = Nothing
End Sub