トップ　>　汎用コード　>　郵便番号から都道府県と市区町村を一括取得・設定

'-----------------------------------------------------
' 郵便番号から住所を取得するマクロ　更新：2023.04.11
'-----------------------------------------------------
'　・ネットに繋がっていないと使用不可
'　・郵便番号のセル範囲を選択してマクロを実行
' https://excel.syogyoumujou.com/vba/zipcode.html
'-----------------------------------------------------
Sub ZipcodeToAddress()
    
    'マクロ実行可否判定
    If TypeName(Selection) <> "Range" Then Exit Sub      'セルを選択していなければ終了
    If 1 < Selection.Columns.Count Then Exit Sub         '選択範囲が2列以上なら終了

    'セルの設定
    Dim rngZip As Range
    Set rngZip = Selection                               '対象セル範囲をセット
    ReDim strID(1 To rngZip.Rows.Count) As String        'セルの個数分のString型配列準備
    
    '郵便番号データ整形
    Dim i As Long
    For i = 1 To rngZip.Rows.Count
        strID(i) = StrConv(rngZip.Cells(i, 1), vbNarrow) '全角の場合は半角に
        strID(i) = Replace$(strID(i), "-", "")           'ハイフンを削除
        strID(i) = Replace$(strID(i), " ", "")           'スペースを削除
        strID(i) = WorksheetFunction.Clean(strID(i))     '改行等削除
    Next

    'HTMLドキュメント取得
    Dim htmlDoc  As Object
    Set htmlDoc = CreateObject("htmlfile")               'インスタンス生成
    Dim strURL   As String
    Dim strRText As String
    strURL = "https://excel.syogyoumujou.com/vba/dl_file/zipcode.html"
    strRText = GetHtmlText(strURL)                       'HTMLテキストを取得
    If strRText = "" Then
        MsgBox "ネット上のデータを取得できませんでした", vbExclamation, "中止します"
        GoTo Finally
    End If
    
    'HTMLドキュメント書き出し
    htmlDoc.Write strRText
    
    '取得したデータの書き出し
    Application.ScreenUpdating = False
    On Error Resume Next
    For i = LBound(strID) To UBound(strID)
        If 0 < Len(strID(i)) Then
            Dim varSpt As Variant
            varSpt = htmlDoc.getElementById(strID(i)).innerTEXT 'ID(郵便番号)から住所取得
            If Err.Number = 0 Then
                varSpt = Split(varSpt, ",")
                rngZip(i, 1).Offset(, 1).Value = varSpt(0) '都道府県書き出し
                rngZip(i, 1).Offset(, 2).Value = varSpt(1) '市区町村書き出し
            Else
                rngZip(i, 1).Offset(, 1).Value = "住所を取得できませんでした"
                Err.Clear
            End If
        End If
    Next
    On Error GoTo 0
    Application.ScreenUpdating = True

Finally:
    Set htmlDoc = Nothing
    Set rngZip = Nothing
End Sub

'-----------------------------------------------------
' HTMLテキスト取得関数
'-----------------------------------------------------
'［引数］
'   URL ：対象ページURL
'［戻り値］
'   成功：HTMLテキスト
'　 失敗：空の文字列
'-----------------------------------------------------
Function GetHtmlText(ByVal URL As String) As String
    On Error Resume Next
    Dim objXMLHTTP As Object
    Set objXMLHTTP = CreateObject("MSXML2.ServerXMLHTTP") 'インスタンス生成
    With objXMLHTTP
        .Open "GET", URL
        .Send                                             'リクエスト送信
        GetHtmlText = .responseText                       'サーバーからの文字列取得
    End With
    Set objXMLHTTP = Nothing
    On Error GoTo 0
End Function

書籍紹介

知りたいがすぐわかる！　やりたいがすぐできる！
「Excel VBA 逆引きで学ぶ ユーザーフォーム&コントロール」（Kindle版）
ユーザーフォームを扱えると、VBAでできることが大きく広がります！
本書では、知りたいこと、やりたいことから、逆引きで学びを深められます。
※　第1章～5章まで公開しています