OUTLOOK EXCEL VBA Outlookのアドレス帳を会社名で検索してメールアドレスを抜き出す

#動作確認環境
Windows 10 Office 2013 32 Bit

#Excel VBA
参照設定 OUTLOOK XX.0 オブジェクトライブラリーを参照設定すること。
アクティブなセルに
中原株式会社　御中
などと差し込み印刷用にスペースや御中と書いてある社名があり、
アドレス帳に
中原株式会社
があれば
「中原」でLike検索をかけて合致したらアクティブなセルの右隣に書き込みます。
株式会社やスペースを除いて検索して表記の揺れによる検索もれを防ぎます。
その反面、中原株式会社の複数の社員を登録していると、最初にヒットしたところが入ります。
なので、Stopをかけてあります。F8でステップさせて、Loacal Windowか実際のExcel画面で望ましいメールアドレスが入ったらリセットで終了させます。
完全自動化しないのは、重複問題があるためです。
完全に会社名がユニークで重複がないのであれば、Stopは不要です。

VBA Script that gets list of Outlook Contacts using the Property Accessorの住所録のデータを抜き出すOUTLOOK VBAを改造してExcel用にしています。
このVBAはかなり仕事を効率化します。重複に注意すれば、Outlookの住所録データを正確に入力していれば、それをデータベースとして利用できるためです。
OUTLOOKの仕様をMSが変更して、法人番号が入るようになると会社名による重複を回避できるようになりますが、国際的にマイナンバーは異常な制度で、日本が国民の間に権威主義と縁故主義が蔓延し、政治体制が後進国の開発独裁に堕落してしまった現状では、もはや先進国でない以上、それは難しいのかもしれません。こんな制度ができるのは民主主義国家ではありませんから。

Sub addressreq()
Dim olaPP As Outlook.Application
Dim olCon As ContactItem
Dim NS As Outlook.Namespace
Dim myLis As Outlook.AddressLists, myLi As Outlook.AddressList
Dim addfilter, ContactFolder, currentItem, StringArray() As String, index, currentstirng As String
Dim oExUser As Outlook.ExchangeUser
Dim currentContact As Outlook.ContactItem
Dim oPA As Outlook.PropertyAccessor
Dim REPORT As String
Set olaPP = Outlook.Application
Set NS = olaPP.GetNamespace("Mapi")
Set ContactFolder = NS.GetDefaultFolder(10)
For Each currentItem In ContactFolder.Items
If (currentItem.Class = olContact) Then
Set currentContact = currentItem
Set oPA = currentContact.PropertyAccessor
REPORT = REPORT & AddToReportIfNotBlank("Auto Forwarded", oPA.GetProperty("http://schemas.microsoft.com/mapi/proptag/0x0005000b")) & vbCrLf
REPORT = REPORT & AddToReportIfNotBlank("City", oPA.GetProperty("urn:schemas:contacts:mailingcity")) & vbCrLf
REPORT = REPORT & AddToReportIfNotBlank("Company name", oPA.GetProperty("urn:schemas:contacts:o")) & vbCrLf
If AddToReportIfNotBlank("Company name", oPA.GetProperty("urn:schemas:contacts:o")) Like "*" & Replace(Replace(Replace(Replace(Replace(ActiveCell.Value, "株式会社", "", 1, -1, vbTextCompare), "有限会社", "", 1, -1, vbTextCompare), "一般財団法人", "", 1, -1, vbTextCompare), " ", "", 1, -1, vbTextCompare), "御中", "", 1, -1, vbTextCompare) & "*" Then
Stop
ActiveCell.Offset(, 1).Value = Replace(AddToReportIfNotBlank(" ", oPA.GetProperty("http://schemas.microsoft.com/mapi/id/{00062004-0000-0000-C000-000000000046}/8084001f")), " : ", "", 1, -1, vbTextCompare)
End If
REPORT = REPORT & "----------------------------------------------------------------------------------" & vbCrLf & vbCrLf
Set oPA = Nothing
End If
Next
Call CreateReport("List of Contacts and properties using various Property Syntaxes", REPORT)
'[VBA Script that gets list of Outlook Contacts using the Property Accessor](http://www.gregthatcher.com/Scripts/VBA/Outlook/GetListOfContactsUsingPropertyAccessor.aspx)
'https://msdn.microsoft.com/ja-jp/library/cc447340.aspx
End Sub
Private Function AddToReportIfNotBlank(FieldName As String, FieldValue)
AddToReportIfNotBlank = ""
If (IsNull(FieldValue) Or FieldValue <> "") Then
AddToReportIfNotBlank = FieldName & " : " & FieldValue
End If

End Function
Public Sub CreateReport(Title As String, REPORT As String)
On Error GoTo On_Error
Debug.Print Title, REPORT
Exiting:
Exit Sub
On_Error:
MsgBox "error=" & Err.Number & " " & Err.Description
Resume Exiting
End Sub