仮置き

説明の都合上の仮置きです。

参照元の記事
OUTLOOK EXCEL VBA Outlookのアドレス帳を会社名で検索してメールアドレスを抜き出す - Qiita

VBA 最奥義（たぶん）クロスプラットフォームスクリプト（仮） - Qiita

Option Explicit

'OUTLOOK EXCEL VBA Outlookのアドレス帳を会社名で検索してメールアドレスを抜き出す - Qiita
'http://qiita.com/Q11Q/items/92c1954e4dcdcc7fa598

'のコードを個人的に見やすいように整理したもの
    '- 変数宣言位置の変更
    '- インデントの変更
    '- 変数の大文字・小文字の変更

    '- 一部型宣言の変更
    '- 一部処理の分割


Sub addressreq()
    '未使用の変数
    'Dim olCon As ContactItem
    'Dim myLis As Outlook.AddressLists, myLi As Outlook.AddressList
    'Dim oExUser As Outlook.ExchangeUser
    'Dim addfilter, StringArray() As String, index, currentstirng As String


    Dim olApp As Outlook.Application
    Set olApp = Outlook.Application

    Dim ns As Outlook.Namespace
    Set ns = olApp.GetNamespace("Mapi")

    Dim contactFolder As Outlook.Folder
    Set contactFolder = ns.GetDefaultFolder(Outlook.OlDefaultFolders.olFolderContacts)

    Dim currentItem As Object, currentContact As Outlook.ContactItem
    Dim oPA As Outlook.PropertyAccessor

    Dim report As String

    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 "*" & Remove_株式会社_等(Excel.ActiveCell.Value) & "*" Then
                Stop
                Excel.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 currentItem

    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

Function Remove_株式会社_等(iSrcTxt As String) As String
    Remove_株式会社_等 = Replace(Replace(Replace(Replace(Replace(iSrcTxt, "株式会社", "", 1, -1, vbTextCompare), "有限会社", "", 1, -1, vbTextCompare), "一般財団法人", "", 1, -1, vbTextCompare), " ", "", 1, -1, vbTextCompare), "御中", "", 1, -1, vbTextCompare)
End Function

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