1
3

More than 3 years have passed since last update.

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

Last updated at Posted at 2020-06-10

関連
HTTPリクエストを投げて、レスポンスを受け取る vbscript
ExcelのVBAでYahoo!路線情報からHTMLを取得して運賃を取得してみる

MSXML2.XML 日本郵便サイトで郵便番号住所変換

Excelだけで年賀状印刷するで使ったものですが、この部分だけ受けが良かったので、切り出しました。
郵便番号の 4桁目=8 をすべて企業郵便番号と仮定しています。(郵便番号のルール理解不足で)
日本郵便サイトで検索した結果をしょりします。なので、マスターとかCSVダウンロードとか必要ありません。
インターネットに接続していないと、変換できません。
Excelの設定変更は必要ありません。ノーマルで大丈夫!
郵便番号変換20061001.png
郵便番号から住所を求める関数を作って、シートで関数を直接使用します。

郵便番号住所変換
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

1
3
0

Register as a new user and use Qiita more conveniently

  1. You get articles that match your needs
  2. You can efficiently read back useful information
  3. You can use dark theme
What you can do with signing up
1
3