関連
HTTPリクエストを投げて、レスポンスを受け取る vbscript
ExcelのVBAでYahoo!路線情報からHTMLを取得して運賃を取得してみる
MSXML2.XML 日本郵便サイトで郵便番号住所変換
Excelだけで年賀状印刷するで使ったものですが、この部分だけ受けが良かったので、切り出しました。
郵便番号の 4桁目=8 をすべて企業郵便番号と仮定しています。（郵便番号のルール理解不足で）
日本郵便サイトで検索した結果をしょりします。なので、マスターとかCSVダウンロードとか必要ありません。
インターネットに接続していないと、変換できません。
Excelの設定変更は必要ありません。ノーマルで大丈夫！
郵便番号から住所を求める関数を作って、シートで関数を直接使用します。
郵便番号住所変換
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