ich habe jetzt länger im Netz gesucht aber nichts "Verständliches" zum Thema gefunden.
Ausgangslage:
1) Ich habe sämtliche Mitarbeiter in Outlook angelegt
2) Ich nutze eine Excel-Liste wo sämtliche Mitarbeiter aufgelistet sind und diesen Hardware sowie Software zuordne die sie verwenden. Aufgabenstellung: 1)Wenn neue Mitarbeiter eingestellt werden trage ich die in die Outlook Liste ein auf welche alle Zugriff haben. Ich möchte diese Datenbank aber mit meiner Excel-Datei verknüpfen, dass ich dort über „aktualisieren“ die neuen oder geänderten Mitarbeiter automatisch habe.
29.08.2017, 09:06 (Dieser Beitrag wurde zuletzt bearbeitet: 29.08.2017, 09:07 von Helvetier.)
Hallo Thomas
Hier ein Makro, welches das "umgekehrte" macht: Nachführen der Outlookkontakte ab einer Excel-"Datenbank". Vielleicht kannst da etwas umbauen.
Gruss
Code:
'Example 3: This example exports data from an Excel Worksheet to the default Contacts folder (new contact items added with Items.Add Method), using Late Binding.
'http://www.globaliconnect.com/excel/index.php?option=com_content&view=article&id=167:import-contacts-from-excel-to-outlook-automate-in-vba&catid=79&Itemid=475
'Anpassungen durch XY
Sub ExcelWorksheetDataAddToOutlookContacts()
'Automating Outlook from Excel: This example uses the Items.Add Method to export data from an Excel Worksheet to the default Contacts folder.
'Automate Outlook from Excel, using Late Binding. You need not add a reference to the
'Outlook library in Excel (your host application), in this case you will not be able to use the Outlook's predefined constants and will need to replace them by their numerical values in your code.
'Ensure that the worksheet data to be posted to Outlook, starts from row number 2:
'Ensure corresponding columns of data in the Worksheet, as they will be posted in the Outlook Contacts Folder:
'Column B: First Name
'Column C: Last Name
'Column Mail: Email Address
'Column D: Company Name
'Column Handy: Mobile Telephone Number
Dim oApplOutlook As Object
Dim oNsOutlook As Object
Dim oCFolder As Object
Dim subFolder1 As Object
Dim oDelFolder As Object
Dim oCItem As Object
Dim oDelItems As Object
Dim lLastRow As Long, i As Long, n As Long, c As Long
'prüfen, ob die Datenquelle geöffnet ist
strFokus = "Mitgliederliste " & sngJahr & strErweiterung
Datei_geöffnet_prüfen
If bolDateiGeöffnet = True Then
MsgBox "Eine Datei """ & strFokus & """ist geöffnet." & VBA.Chr(13) & VBA.Chr(10) & _
"Schliesse bitte die Datei """ & strFokus & """ ." & VBA.Chr(13) & VBA.Chr(10) & _
"Betätige noch einmal den """ & strCaption & """-Button."
GoTo Endhandler
End If
'prüfen, ob die Datenquelle im Ordner "MITGLIEDERLISTE" vorhanden ist
strPfad = VBA.Left(ThisWorkbook.Path, VBA.InStrRev(ThisWorkbook.Path, "\", -1) - 1) & "\" & VBA.UCase(VBA.Left(strFokus, VBA.InStr(strFokus, " ") - 1))
strFile = strPfad & "\" & strFokus
Quelle_vorhanden
If bolQuelleExistiert = False Then
MsgBox "Eine Datei """ & strFokus & """ im Verzeichnis " & VBA.Chr(13) & VBA.Chr(10) & _
"" & strPfad & "" & VBA.Chr(13) & VBA.Chr(10) & _
"gibt es nicht."
GoTo Endhandler
End If
On Error GoTo keinMerker
Application.ScreenUpdating = False
'determine last data row in the worksheet:
lLastRow = Sheets("Adressenliste").Cells(Rows.Count, "A").End(xlUp).Row
'Create a new instance of the Outlook application, if an existing Outlook object is not available.
'Set the Application object as follows:
On Error Resume Next
Set oApplOutlook = GetObject(, "Outlook.Application")
'if an instance of an existing Outlook object is not available, an error will occur (Err.Number = 0 means no error):
If Err.Number <> 0 Then
Set oApplOutlook = CreateObject("Outlook.Application")
End If
'disable error handling:
On Error GoTo 0
'use the GetNameSpace method to instantiate (ie. create an instance) a NameSpace object variable, to access existing Outlook items. Set the NameSpace object as follows:
Set oNsOutlook = oApplOutlook.GetNamespace("MAPI")
'----------------------------
''Empty the Deleted Items folder in Outlook so that when you quit the Outlook application you bypass the prompt: Are you sure you want to permanently delete all the items and subfolders in the "Deleted Items" folder?
'set the default Deleted Items folder:
'The numerical value of olFolderDeletedItems is 3.
'The following code has replaced the Outlook's built-in constant olFolderDeletedItems by its numerical value 3.
Set oDelFolder = oNsOutlook.GetDefaultFolder(10) 'findet den Ordner "Kontakte"
Set subFolder1 = oDelFolder.Folders("Seniorenriege") 'finden im Ordner "Kontakte" den Unterordner "Seniorenriege"
'set the items collection:
Set oDelItems = subFolder1.Items
'determine number of items in the collection:
c = oDelItems.Count
'start deleting from the last item:
For n = c To 1 Step -1
oDelItems(n).Delete
Next n
'----------------------------
'set reference to the default Contact Items folder:
'The numerical value of olFolderContacts is 10.
'The following code has replaced the Outlook's built-in constant olFolderContacts by its numerical value 10.
strKontakt = "Seniorenriege"
Set oCFolder = oNsOutlook.GetDefaultFolder(10)
Set subFolder1 = oCFolder.Folders(strKontakt)
'post each row's data on a separate contact item form:
For i = 4 To lLastRow
If Sheets("Adressenliste").Cells(i, 1) <> "-" Then
'die folgende Wenn-Prüfung ist anzuwenden,wenn Outlook auch von den Turnern ein Konto
'einrichten soll, die keine Mail-Adresse haben.
'If Sheets("Adressenliste").Cells(i, Range("Mail").Column) <> "" Then
'Using the Items.Add Method to create a new Outlook contact item in the default Contacts folder.
Set oCItem = subFolder1.Items.Add
'display the new contact item form:
'Anzeige nicht notwendig
'oCItem.Display
'set properties of the new contact item:
With oCItem
.firstName = Sheets("Adressenliste").Cells(i, 3).Value
.lastName = Sheets("Adressenliste").Cells(i, 2).Value
.Email1Address = Sheets("Adressenliste").Cells(i, Range("Mail").Column).Value
'.Funktionär=Sheets("Adressenliste").Cells(i, Range("Funktionär").Column)
.HomeAddressStreet = Sheets("Adressenliste").Cells(i, Range("Strasse").Column).Value
.HomeAddressPostalCode = Sheets("Adressenliste").Cells(i, Range("Postleit").Column).Value
.HomeAddressCity = Sheets("Adressenliste").Cells(i, Range("Wohnort").Column).Value
.CompanyName = strKontakt '"Seniorenriege" 'subFolder1
.HomeTelephoneNumber = Sheets("Adressenliste").Cells(i, Range("Telefon").Column).Value
.MobileTelephoneNumber = Sheets("Adressenliste").Cells(i, Range("Handy").Column).Value
.Save
End With
'Stop
'close the new contact item form after saving:
'The numerical value of olSave is 0. The following code has replaced the Outlook's built-in constant olSave by its numerical value 0.
'oCItem.Close 0
'End If
End If
Next i
keinMerker:
On Error GoTo 0
oCItem.Close 0
Workbooks(strFokus).Close savechanges:=False
Application.ScreenUpdating = True
'quit the Oulook application:
oApplOutlook.Quit
'clear the variables:
Set oApplOutlook = Nothing
Set oNsOutlook = Nothing
Set oCFolder = Nothing
Set oDelFolder = Nothing
Set oCItem = Nothing
Set oDelItems = Nothing
MsgBox "Das Adressbuch von Outlook ist hiermit mit der Adressenliste der Seniorenriege synchronisiert."
Endhandler:
End Sub
leider ist das nicht möglich da mehrere Personen in der Outlook Datenbank Informationen hinterlegen. Ich müsste den Export dann von dort in meine Excel Liste tätigen und um nicht immer mehrere Schritte zu tätigen möchte ich auch vermeiden immer ein neues Arbeitsblatt in meine Arbeitsmappe zu importieren und die Verweise neu zu setzen wäre eine Datenverknüpfung sehr hilfreich.
Es gibt Maschinen, die sehr leistungsfähig sind.
Dazu gehören auch Suchmaschinen.
Und ich hebe eben einmal die Begriffe excel zugriff outlook adressbuch eingegeben.
Reichen die 86.500 Ergebnisse?
Beste Grüße Günther
Excel-ist-sexy.de …schau doch mal rein! Der Sicherheit meiner Daten wegen lade ich keine *.xlsm bzw. *.xlsb- Files mehr herunter! -> So geht's ohne!
