BB

Sub ExportGALToExcelOptimized()
    Dim olApp As Outlook.Application
    Dim olNS As Outlook.Namespace
    Dim olGAL As Outlook.AddressList
    Dim olEntries As Outlook.AddressEntries
    Dim olEntry As Outlook.AddressEntry
    Dim olUser As Outlook.ExchangeUser
    Dim xlApp As Object
    Dim xlWB As Object
    Dim xlWS As Object
    Dim i As Long
    Dim dataArray() As Variant

    ' Initialize Outlook
    Set olApp = Outlook.Application
    Set olNS = olApp.GetNamespace("MAPI")
    Set olGAL = olNS.AddressLists("Global Address List")
    Set olEntries = olGAL.AddressEntries

    ' Initialize Excel
    Set xlApp = CreateObject("Excel.Application")
    xlApp.Visible = True
    Set xlWB = xlApp.Workbooks.Add
    Set xlWS = xlWB.Sheets(1)

    ' Add headers to Excel
    xlWS.Cells(1, 1).Value = "Name"
    xlWS.Cells(1, 2).Value = "Email"
    xlWS.Cells(1, 3).Value = "Job Title"
    xlWS.Cells(1, 4).Value = "Department"
    xlWS.Cells(1, 5).Value = "Manager"

    ' Pre-size the array to hold all entries
    ReDim dataArray(1 To olEntries.Count, 1 To 5)

    ' Loop through GAL entries and populate the array
    i = 1
    For Each olEntry In olEntries
        If olEntry.AddressEntryUserType = olExchangeUserAddressEntry Then
            Set olUser = olEntry.GetExchangeUser
            If Not olUser Is Nothing Then
                dataArray(i, 1) = olUser.Name
                dataArray(i, 2) = olUser.PrimarySmtpAddress
                dataArray(i, 3) = olUser.JobTitle
                dataArray(i, 4) = olUser.Department
                If Not olUser.GetExchangeUserManager Is Nothing Then
                    dataArray(i, 5) = olUser.GetExchangeUserManager.Name
                Else
                    dataArray(i, 5) = "No Manager"
                End If
                i = i + 1
            End If
        End If
    Next olEntry

    ' Write the array to Excel in one operation
    xlWS.Range("A2").Resize(UBound(dataArray, 1), UBound(dataArray, 2)).Value = dataArray

    ' Autofit columns
    xlWS.Columns("A:E").AutoFit

    ' Clean up
    Set olUser = Nothing
    Set olEntry = Nothing
    Set olEntries = Nothing
    Set olGAL = Nothing
    Set olNS = Nothing
    Set olApp = Nothing

    MsgBox "Export complete!", vbInformation
End Sub

# Import Outlook COM object
$outlook = New-Object -ComObject Outlook.Application
$namespace = $outlook.GetNamespace("MAPI")
$GAL = $namespace.GetGlobalAddressList()
$entries = $GAL.AddressEntries

# Use parallel processing to process entries
$results = $entries | ForEach-Object -Parallel {
    try {
        $user = $_.GetExchangeUser()
        if ($user) {
            [PSCustomObject]@{
                Name        = $user.Name
                Email       = $user.PrimarySmtpAddress
                JobTitle    = $user.JobTitle
                Department  = $user.Department
                Manager     = if ($user.GetExchangeUserManager()) { $user.GetExchangeUserManager().Name } else { "No Manager" }
            }
        }
    } catch {}
} -ThrottleLimit 4  # Adjust the throttle limit based on your system

# Export results to CSV
$results | Export-Csv -Path "$env:USERPROFILE\Desktop\GlobalAddressList.csv" -NoTypeInformation

Write-Host "Export complete! File saved to Desktop."