excelからOutlook365のアドレス帳にアクセスし指定のアドレスを取得したい。
取得事態はできているのだが、同一同名や１人に複数のアドレスを持った人がいた場合、
それらも取得したいが、１件（最初にヒットしたもののみ）しか取得できない。
以下が、VBAの内容になるが何処をどうすればよいかお力を貸していただければ幸いです。
よろしくお願いいたします。
Sub アドレス取得()
Dim outlookApp As Object
Dim outlookNamespace As Object
Dim addressList As Object
Dim addressEntries As Object
Dim ae As Object
Dim exchangeUser As Object
Dim ws As Worksheet
Dim i As Long, j As Long, startIndex As Long
Dim searchKey As String, cleanKey As String
Dim checkName As String
Set ws = ActiveSheet
' A2セルからフルネームを取得
searchKey = ws.Range("F2").Value
If searchKey = "" Then
MsgBox "F2セルに検索するフルネームを入力してください。", vbExclamation, "入力エラー"
Exit Sub
End If
' 検索ワードからスペースを除去
cleanKey = Replace(Replace(searchKey, " ", ""), " ", "")
' 画面更新を一瞬止める（高速化）
Application.ScreenUpdating = False
' 【変更】I列:J列の古いデータをすべてクリア
ws.Range("I:J").Clear
' 【変更】H1:I1 に見出し（タイトル）を作成
'ws.Range("H1:I1").Value = Array("部署/役職", "メールアドレス")
' 【変更】データはI2:J2（2行目）から書き出し開始
i = 2
On Error Resume Next
Set outlookApp = CreateObject("Outlook.Application")
Set outlookNamespace = outlookApp.GetNamespace("MAPI")
' グローバルアドレス一覧（GAL）を取得
For Each addressList In outlookNamespace.AddressLists
If addressList.AddressListType = 0 Then
Set addressEntries = addressList.addressEntries
Exit For
End If
Next addressList
If addressEntries Is Nothing Then
Set addressEntries = outlookNamespace.AddressLists(1).addressEntries
End If
On Error GoTo 0
' フルネームでその名前の登録位置へ
On Error Resume Next
Set ae = addressEntries.Item(searchKey)
If ae Is Nothing Then Set ae = addressEntries.Item(cleanKey)
On Error GoTo 0
' その周辺に同姓同名がいないかスキャン
If Not ae Is Nothing Then
On Error Resume Next
startIndex = ae.Index
On Error GoTo 0
' インデックスが取得できなかった場合
If startIndex <= 0 Then
' 【変更】E列(5)に氏名を書き出し
' ws.Cells(i, 5).Value = ae.Name
If ae.AddressEntryUserType = 0 Or ae.AddressEntryUserType = 5 Then
Set exchangeUser = ae.GetExchangeUser
If Not exchangeUser Is Nothing Then
' 【変更】I列(9)に部署、J列(10)にアドレスを書き出し
ws.Cells(i, 9).Value = exchangeUser.Department
ws.Cells(i, 10).Value = exchangeUser.PrimarySmtpAddress
End If
End If
If ws.Cells(i, 10).Value = "" Then ws.Cells(i, 10).Value = ae.Address
i = i + 1
GoTo Finalize
End If
' 同じ名前が続く限り（最大10名まで）連続して抽出
For j = startIndex To addressEntries.Count
Set ae = Nothing
On Error Resume Next
Set ae = addressEntries.Item(j)
On Error GoTo 0
If ae Is Nothing Then Exit For
' 登録名からスペースを除去して判定
checkName = Replace(Replace(ae.Name, " ", ""), " ", "")
' フルネームが完全一致するか判定
If checkName = cleanKey Then
' 【変更】E列(5)に氏名を書き出し
'ws.Cells(i, 5).Value = ae.Name
' ユーザー情報を取得
If ae.AddressEntryUserType = 0 Or ae.AddressEntryUserType = 5 Then
On Error Resume Next
Set exchangeUser = ae.GetExchangeUser
If Not exchangeUser Is Nothing Then
' 【変更】F列(6)に部署、G列(7)にアドレスを書き出し
ws.Cells(i, 9).Value = exchangeUser.Department
ws.Cells(i, 10).Value = exchangeUser.PrimarySmtpAddress
End If
On Error GoTo 0
End If
' 【変更】メールアドレスが空の場合の代替処理（G列）
If ws.Cells(i, 11).Value = "" Then ws.Cells(i, 11).Value = ae.Address
i = i + 1
Else
' 違う名前に切り替わったらその時点でループを即座に終了（安全・超高速）
Exit For
End If
' 同姓同名が10人を超えたら安全のために終了
If (i - 2) >= 10 Then Exit For
Next j
End If
Finalize:
' メモリ解放
Set exchangeUser = Nothing
Set ae = Nothing
Set addressEntries = Nothing
Set addressList = Nothing
Set outlookNamespace = Nothing
Set outlookApp = Nothing
Application.ScreenUpdating = True
' 結果のポップアップ表示（2行目から書き始めているため、件数は i - 2）
If i = 2 Then
MsgBox "「" & searchKey & "」に一致するユーザーは見つかりませんでした。", vbExclamation, "検索結果：0件"
ElseIf (i - 2) > 1 Then
' 【変更】メッセージ内の案内列をE列?G列に修正
MsgBox "検索が完了しました。同姓同名の方が " & (i - 2) & " 名見つかりました。" & vbCrLf & _
"F列の「部署名」を確認して、目的の人物か見分けてください。", vbInformation, "複数ヒット"
Else
MsgBox "検索が完了しました。アドレスを取得しました。", vbInformation, "検索完了"
End If
End Sub
