Office: durchsuchen des Globalen Adressbuch von Outlook nach einer Texteingabe in Excel

DerFan91 · 18. September 2012

Guten Tag zusammen,

ich brauche Hilfe bei einem VBA Makro.
Ich gebe in Exel in einer Inputbox die Personalnummer des Mitarbeiter ein den ich auswählen will.
Daraufhin soll per Makro aus dem globalen Adressbuch der entsprechende Mitarbeiter gefunden werden.
In dem globalen Adressbuch sind alle unsere Mitarbeiter vorhanden (über 200 000 Einträge!!!) in dem Feld (Job)Titel ist die Personalnummer.

Ich habe bereits einen Code (siehe unten) gefunden der in VBA funktioniert, aber nur, wenn ich ihn in ein Projekt direkt in Outlook ausführe, nicht jedoch in Excel!
In dem Code habe ich die PersonalNr zum testen fest eingetragen.

Desweiteren ist dieser Code sehr langsam und braucht ca. 1min 10sek bis er das passende Ergebnis gefunden hat - in Outlook über die Adressbuch Suche ist der Eintrag sofort da wenn man auf suchen klickt.

Hat jemand einen Code der in Excel funktioniert und auch noch schnell ist?

Mit freundlichen Grüßen
DerFan

Code:

' by AddressEntry.GetExchangeUser method (Outlook)
Sub DemoAE()

Dim colAL As Outlook.AddressLists
Dim oAL As Outlook.AddressList
Dim colAE As Outlook.AddressEntries
Dim oAE As Outlook.AddressEntry
Dim oExUser As Outlook.ExchangeUser

Set colAL = Application.Session.AddressLists

For Each oAL In colAL
'Address list is an Exchange Global Address List
If oAL.AddressListType = olExchangeGlobalAddressList Then
Set colAE = oAL.AddressEntries
For Each oAE In colAE
If oAE.AddressEntryUserType = olExchangeUserAddressEntry _
Or oAE.AddressEntryUserType = olExchangeRemoteUserAddressEntry Then
Set oExUser = oAE.GetExchangeUser
PersonalNr= "66778899"
If (PersonalNr= oExUser.JobTitle) Then
MsgBox ("Found" & oExUser.Name)
Exit Sub
End If
End If
Next
End If
Next
End Sub
Klicke in dieses Feld, um es in vollständiger Größe anzuzeigen.

:)

Schmali · 20. September 2012

Hoi,

aktivier in den Verweisen als erstes "Microsoft Outlook x.0 Object Library".

Anschließend probier mal nachfolgenden Code aus. Der Code stammt nicht von mir, da man das Rad ja nicht neu erfinden muss, sollte aber zum Verständnis und als Einstieg behilflich sein:

Code:

Public Sub AList()

Dim outApp As Outlook.Application
Dim outNms As Outlook.Namespace
Dim outAddr As Outlook.AddressList
Dim outRcpts As Outlook.AddressEntries
Dim outRcpt As Outlook.AddressEntry

On Error GoTo hError

Set outApp = New Outlook.Application
Set outNms = outApp.GetNamespace("MAPI")
Set outAddr = outNms.AddressLists("Kontakte")
Set outRcpts = outAddr.AddressEntries

MsgBox "Global Address List contains " & outRcpts.Count & " entries.", vbInformation + vbOKOnly, "Info"
i = 1
For Each outRcpt In outRcpts
Range("A" & i).Value = outRcpt.Name
Range("B" & i).Value = outRcpt.Address
i = i + 1
Next outRcpt

Exit Sub

hError:

Err.Raise Err.Number, Err.Source, Err.Description, Err.HelpFile, Err.HelpContext

End Sub
Klicke in dieses Feld, um es in vollständiger Größe anzuzeigen.

Greetz

Schmali

DerFan91 · 24. September 2012

Hi

Vielen Dank für diesen Code

Ich habe diesen modifiziert und kopiere jetzt die Daten aus dem Globalen Addressbuch in eine Excel Tabelle (Dauer ca 20 Min. bei 150 000 Einträgen):

Code:

Public Sub SyncWithGlobalAddressList()
Dim i As Long
' config before using
screenUpdateState = Application.ScreenUpdating
statusBarState = Application.DisplayStatusBar
calcState = Application.Calculation
eventsState = Application.EnableEvents
displayPageBreakState = ActiveSheet.DisplayPageBreaks
' turn off some Excel functionality so your code runs faster
Application.ScreenUpdating = False
Application.DisplayStatusBar = False
Application.Calculation = xlCalculationManual
Application.EnableEvents = False
ActiveSheet.DisplayPageBreaks = False
Application.EnableEvents = False

Start = Now
Dim outApp As Outlook.Application
Dim outNms As Outlook.Namespace
Dim outAddr As Outlook.AddressList
Dim outRcpts As Outlook.AddressEntries
Dim outRcpt As Outlook.AddressEntry

On Error GoTo hError

Set outApp = New Outlook.Application
Set outNms = outApp.GetNamespace("MAPI")
Set outAddr = outNms.AddressLists("Global Address List")
Set outRcpts = outAddr.AddressEntries

Dim Auswahl As Long

Auswahl = MsgBox("Dauer ca. 20 Min. - alte Daten werden entfernt" & vbCrLf _
& "Wollen dennoch fortfahren?", _
vbYesNo + vbExclamation, "ACHTUNG")
Select Case Auswahl
Case vbNo
Exit Sub
Case vbYes
End Select

Sheets("allpersons").Select
Cells.Select
Selection.ClearContents

MsgBox "Global Address List contains " & outRcpts.Count & " entries.", vbInformation + vbOKOnly, "Info"
i = 1
For Each outRcpt In outRcpts

If outRcpt.AddressEntryUserType = olExchangeUserAddressEntry _
Or outRcpt.AddressEntryUserType = olExchangeRemoteUserAddressEntry Then

Set oExchangeUser = outRcpt.GetExchangeUser

Range("A" & i).Value = outRcpt.Name
Range("B" & i).Value = oExchangeUser.JobTitle
i = i + 1
End If
Next outRcpt

Application.EnableEvents = True
Application.ScreenUpdating = screenUpdateState
Application.DisplayStatusBar = statusBarState
Application.Calculation = calcState
Application.EnableEvents = eventsState
ActiveSheet.DisplayPageBreaks = displayPageBreaksState
ende = Now

MsgBox ("Startzeit: " & Start & " Ende: " & ende)
hError:
Err.Raise Err.Number, Err.Source, Err.Description, Err.HelpFile, Err.HelpContext
End Sub
Klicke in dieses Feld, um es in vollständiger Größe anzuzeigen.

Office: durchsuchen des Globalen Adressbuch von Outlook nach einer Texteingabe in Excel

durchsuchen des Globalen Adressbuch von Outlook nach einer Texteingabe in Excel

durchsuchen des Globalen Adressbuch von Outlook nach einer Texteingabe in Excel

durchsuchen des Globalen Adressbuch von Outlook nach einer Texteingabe in Excel - Similar Threads - durchsuchen Globalen Adressbuch

Excel Liste nach Einträgen durchsuchen

Mehrere Spalten durchsuchen und Wert von anderen Zelle ausgeben

Tabelle durchsuchen mehrere Kriterien

Zeilen nach XWert durchsuchen und nMal in Ziel kopieren

Excel VBA Datei durchsuchen, Datentyp prüfen und bestimmten Inhalt auslesen

VBA Makro: Tabelle nach 2 Kriterien durchsuchen & in diese Zeile weitere Werte eintragen

Spalte mit Art. Nr. durchsuchen und bei Treffer diese Art. Nr. in die Nachbarspalte ausgeben