仮置き

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

参照元の記事
[OUTLOOK EXCEL VBA Outlookのアドレス帳を会社名で検索してメールアドレスを抜き出す - Qiita](http://qiita.com/Q11Q/items/92c1954e4dcdcc7fa598 "OUTLOOK EXCEL VBA Outlookのアドレス帳を会社名で検索してメールアドレスを抜き出す - Qiita")

[VBA 最奥義（たぶん）クロスプラットフォームスクリプト（仮） - Qiita](http://qiita.com/Q11Q/items/65987018247d96982f14 "VBA 最奥義（たぶん）クロスプラットフォームスクリプト（仮） - Qiita")

```vbnet
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
```