Outlookアドレス帳のアドレス一覧を取得するマクロ

Sub アドレス帳からアドレス一覧を取得する処理()
    Dim myNameSpace As Outlook.Namespace
    Dim myAddressList As Outlook.AddressList
    Dim myAddressEntries As Outlook.AddressEntries
    Dim myApplication As Outlook.Application: Set myApplication = Outlook.Application
    
    Set myNameSpace = myApplication.GetNamespace("MAPI")
    Set myAddressList = myNameSpace.AddressLists("Offline Global Address List")
    Set myAddressEntries = myAddressList.AddressEntries
    
    ' テーブルのデータ部のみを初期化する
    Dim ws As Worksheet: Set ws = ActiveSheet
    Dim tbl As ListObject: Set tbl = ws.ListObjects("テーブル1")
    If tbl.ListRows.Count <> 0 Then tbl.DataBodyRange.Delete xlUp
    
    ' ユーザー数分転記する
    Dim lastRow As Long, cntUser As Long
    Dim l As AddressEntry
    Dim oExUser As ExchangeUser
    For Each l In myAddressEntries
        Set oExUser = l.GetExchangeUser
        If Not oExUser Is Nothing Then
            ' テーブルの最下行を取得する
            Set tbl = ws.ListObjects("テーブル1")
            lastRow = tbl.ListRows.Count + 2
            ws.Cells(lastRow, 1) = oExUser.PrimarySmtpAddress      'メールアドレス
            ws.Cells(lastRow, 2) = oExUser.Name                    '氏名
            ws.Cells(lastRow, 3) = oExUser.CompanyName             '社名
            ws.Cells(lastRow, 4) = oExUser.Department              '部署
            ws.Cells(lastRow, 5) = oExUser.OfficeLocation          '事業所
            ws.Cells(lastRow, 6) = oExUser.JobTitle                '役職
            cntUser = cntUser + 1
        End If
    Next
    MsgBox "取得が完了しました" & vbCrLf & _
            "ユーザー数：" & cntUser, vbInformation
End Sub