Einfügen in neuem Tabellenblatt
Space
ich habe folgendes Problem. Über einen Button auf dem Tabellenblatt1 will ich das Tabellenblatt 3 (Outlook Kontakte) öffnen und die Outlook entnommenen Kontakte dort eintragen lassen. Der Zugriff auf Outlook funktioniert wunderbar. Die Werte die er dort heraus bekommt trägt er aber in Tabellenblatt1 (Menu) anstatt ins Tabellenblatt3 (Outlook Kontakte) ein.
Kann mir jemand weiterhelfen? Hier mein Code:
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
Vielen Dank!
Gruß
Space