Excel 郵便番号→住所変換　MSXML2.XML HTTP.3.0

関連
[HTTPリクエストを投げて、レスポンスを受け取る vbscript](https://qiita.com/granpa/items/a80325854c92ea53e9f5)
[ExcelのVBAでYahoo!路線情報からHTMLを取得して運賃を取得してみる](https://qiita.com/granpa/items/c0a06011654b40bd6e16)

# MSXML2.XML 日本郵便サイトで郵便番号住所変換
[Excelだけで年賀状印刷する](https://qiita.com/granpa/items/249bb15b3ef8ccaa1921)で使ったものですが、この部分だけ受けが良かったので、切り出しました。
郵便番号の 4桁目=8 をすべて企業郵便番号と仮定しています。（郵便番号のルール理解不足で）
日本郵便サイトで検索した結果をしょりします。なので、マスターとかCSVダウンロードとか必要ありません。
インターネットに接続していないと、変換できません。
Excelの設定変更は必要ありません。ノーマルで大丈夫！
![郵便番号変換20061001.png](https://qiita-image-store.s3.ap-northeast-1.amazonaws.com/0/646883/5dc5b3f6-7415-f7ec-eb41-5eb01cc749bb.png)
郵便番号から住所を求める関数を作って、シートで関数を直接使用します。

```vba:郵便番号住所変換
Option Explicit

'-------------------------------------
'web日本郵便から郵便番号データを取得する MSXML2.XMLHTTP.3.0
'20200610 企業郵便番号対応 4桁目=8 をすべて企業郵便番号と仮定
'-------------------------------------
Public Function postAddress2homeAddress(postAddress As String)
    Dim oXMLHTTP                    ' MSXMLオブジェクト
    Dim resData As String           ' レスポンス
    Dim resDataAry As Variant
    Dim rew As Variant
    Dim rc As Boolean
    Dim matchArray As Variant
    Dim i As Variant
    Dim mode As String
    Dim getUrl As String
    Dim sPost As String

    Set oXMLHTTP = CreateObject("MSXML2.XMLHTTP.3.0")
    postAddress2homeAddress = ""

    sPost = Replace(postAddress, "-", "", 1, -1, vbBinaryCompare) '-除去
    sPost = Replace(sPost, "ー", "", 1, -1, vbBinaryCompare)
    
    If Len(sPost) <> 7 Then GoTo EndProc

    If Mid(sPost, 4, 1) = "8" Then
        getUrl = "https://www.post.japanpost.jp/cgi-zip/business/business.php?zip=" & sPost     '個人
        mode = "busi"
    Else
        getUrl = "https://www.post.japanpost.jp/cgi-zip/zipcode.php?zip=" & sPost               '企業
        mode = "pers"
    End If

    ' 同期処理
    oXMLHTTP.Open "GET", getUrl, False
    On Error Resume Next
    oXMLHTTP.Send
    If Err.Number <> 0 Then GoTo EndProc
    On Error GoTo 0
        
    If oXMLHTTP.Status = 200 Then
        resData = oXMLHTTP.responseText
        resData = Replace(resData, Chr(34), "", 1, -1, vbBinaryCompare)   '正規表現を簡単にするためにダブルクオーテーションを除去
        If InStr(1, resData, "該当する郵便番号が見つかりませんでした", vbBinaryCompare) < 1 Then
            Select Case mode
                Case "busi"
                    rc = RegExpMatch(resData, "<td class=data>(.*?)</td>", matchArray, False, True)
                    If rc Then
                        postAddress2homeAddress = postAddress2homeAddress & RegExpReplace(matchArray(1, 2), "", "<([^]*|'[^']*'|[^'>])*>", False, True)     'タグの除去 都道府県
                        postAddress2homeAddress = postAddress2homeAddress & RegExpReplace(matchArray(1, 3), "", "<([^]*|'[^']*'|[^'>])*>", False, True)     'タグの除去 市区町村
                        postAddress2homeAddress = postAddress2homeAddress & RegExpReplace(matchArray(1, 4), "", "<([^]*|'[^']*'|[^'>])*>", False, True)     'タグの除去 町域丁目・番地等
                        postAddress2homeAddress = postAddress2homeAddress & RegExpReplace(matchArray(1, 0), "", "<([^]*|'[^']*'|[^'>])*>", False, True)     'タグの除去 事業所名
                    End If
                Case "pers"
                    rc = RegExpMatch(resData, "<td class=data><small>(.*?)</small></td>", matchArray, False, True)
                    If rc Then
                        For i = 0 To UBound(matchArray, 2)
                            postAddress2homeAddress = postAddress2homeAddress & RegExpReplace(matchArray(1, i), "", "<([^]*|'[^']*'|[^'>])*>", False, True)     'タグの除去
                        Next
                    End If
                    rc = RegExpMatch(resData, "<a class=line.*>(.*?)</a>", matchArray, False, True)
                    If rc Then postAddress2homeAddress = postAddress2homeAddress & RegExpReplace(matchArray(1, 0), "", "<([^]*|'[^']*'|[^'>])*>", False, True)  'タグの除去
            End Select
        End If
    End If
    
EndProc:
    Set oXMLHTTP = Nothing
End Function

 '-------------------------------------------
 ' マッチ
 ' [string_]内に[patrn_]と一致するものを検索する、その結果と、一致するものの文字位置と文字を返す
 '-------------------------------------------
 ' 引数
 '   string_     : 検索対象文字列
 '   patrn_      : 検索パターン
 '   AnsArray_   :
 '   IgnoreCase_ : 大文字と小文字を区別指定
 '                 true  : 大文字と小文字を区別します
 '                 false : 大文字と小文字を区別しない
 '   Global_     : 検索範囲指定
 '                 true  : 文字列全体を検索する
 '                 false : 最初の一致まで検索する
 '
 ' 戻り値
 '   RegExpMatch : false     検索結果で一致するものが存在しない
 '               : true      検索結果で一致するものが存在する
 '   AnsArray(x,y)           一致するものの文字位置と文字
 '   AnsArray(0,y)           一致するものの文字位置
 '   AnsArray(1,y)           一致する文字
 '-------------------------------------------
 Private Function RegExpMatch(string_, patrn_, AnsArray_, IgnoreCase_, Global_)
        Dim regEx: Set regEx = CreateObject("VBScript.RegExp")             ' 正規表現を作成します。
        Dim Match                                                          ' 一致文字位置と文字コレクションを受け取るWK
        Dim Matches                                                        ' 検索実行結果を受け取る
        Dim fAnsArray(): ReDim fAnsArray(1, 0)                             ' 一致するものの文字位置と文字配列

        regEx.Pattern = patrn_                                             ' パターンを設定します。
        regEx.IgnoreCase = IgnoreCase_                                     ' 大文字と小文字を区別
        regEx.Global = Global_                                             ' 検索範囲指定

        Set Matches = regEx.Execute(string_)                               ' 検索を実行します。(検索結果で一致するものがなくても配列が返る)

        RegExpMatch = False                                                ' 検索結果で一致するものが存在しないにする
        For Each Match In Matches                                          ' Matches コレクションに対して繰り返し処理を行います。
            If RegExpMatch Then
               ReDim Preserve fAnsArray(1, UBound(fAnsArray, 2) + 1)       ' AnsArrayの拡張
            End If
            RegExpMatch = True                                             ' 検索結果で一致するものが存在する
            fAnsArray(0, UBound(fAnsArray, 2)) = Match.FirstIndex          ' 一致する文字列が見つかった位置
            fAnsArray(1, UBound(fAnsArray, 2)) = Match.Value               ' 一致した文字列
        Next

        AnsArray_ = fAnsArray

        Set regEx = Nothing                                                ' 正規表現を作成します
        Set Match = Nothing                                                ' 一致文字位置と文字コレクションを受け取るWK
        Set Matches = Nothing                                              ' 検索実行結果を受け取る
        Erase fAnsArray
 End Function
 
 '-------------------------------------------
 ' 置換
 ' [string_]内に[patrn_]と一致するものを[replStr_]へ置換を行った結果を返す
 '-------------------------------------------
 ' 引数
 '   string_     : 検査対象文字列
 '   replStr_    : 置換え文字列
 '   patrn_      : 検査パターン
 '   IgnoreCase_ : 大文字と小文字を区別指定
 '                 true  : 大文字と小文字を区別します
 '                 false : 大文字と小文字を区別しない
 '   Global_     : 検索範囲指定
 '                 true  : 文字列全体を検索する
 '                 false : 最初の一致まで検索する
 ' 戻り値
 '   RegExpReplace : 置換を行った結果
 '-------------------------------------------
 Private Function RegExpReplace(string_, replStr_, patrn_, IgnoreCase_, Global_)
        If IsNull(string_) Or string_ = "" Then
           RegExpReplace = ""
           Exit Function
        End If
        
        Dim regEx: Set regEx = CreateObject("VBScript.RegExp")             ' 正規表現を作成します。
        regEx.Pattern = patrn_                                             ' パターンを設定します。
        regEx.IgnoreCase = IgnoreCase_                                     ' 大文字と小文字を区別
        regEx.Global = Global_                                             ' 検索範囲指定
        RegExpReplace = regEx.Replace(string_, replStr_)                   ' 置換します。
        Set regEx = Nothing
 End Function
```
[物忘れ防止 郵便番号住所変換_日本郵便サイト.xlsm ](https://github.com/sugita0301/douzo)