エクセルVBAで、郵便番号から住所の読み方を調べて表示するサンプルファイル

エクセルのVBAで、郵便番号から住所の読み方を表示したかったので作りました。
なかなか便利だったのでサンプルファイルを公開します。
Module1の記述を改造して使ってくださいね。

※VBAなので、VBAがわかる人用のファイルです。

サンプルファイル

エクセルのマクロをオンにして、解凍した「郵便番号から住所の読み方を表示するサンプル.xlsm」を開いてください。

「住所の読み方を調べる」ボタンを押すと、郵便番号を入力するダイアログが表示されます。

• zipcode2addressyomi.zip

動作のサンプル

こんな感じの動作をします。

VBAの記述

'================================================================================
' ボタンの動作
'================================================================================

Sub btn_住所の読み方を表示()

    Dim ans As String
    Dim str As String
 
    'ダイアログボックスで郵便番号を入力
    ans = InputBox("郵便番号を入力してください" & vbCrLf & vbCrLf & _
    "※郵便番号が7桁以外だと正しく表示されません。" & vbCrLf & _
    "※ハイフンはあってもなくても大丈夫です。" & vbCrLf & _
    "※全角でも半角でもOKです。")


    '何か入力されて「OK」ボタンが押された時のみ実行
    If ans <> "" Then
        '読み方を関数で取得
        str = GetAddressYomi(ans)
     
        'メッセージボックスで表示
        If str <> "" Then
            MsgBox (str)
        End If
    End If

End Sub




'================================================================================
' インターネットで住所の読み方を取得して返す関数
' 日本ソフト販売株式会社の郵便番号検索を使う
'================================================================================

Function GetAddressYomi(zipcode As String)
 
    '準備 --------------------
 
    On Error GoTo myError
 
    Dim objIE As Object
    Dim str As String
    Dim kanji(2) As String
    Dim kana(2) As String
    Dim space(3) As String
 
 

    '処理開始 --------------------
 
    '郵便番号を半角にしておく
    zipcode = StrConv(zipcode, vbNarrow)



    'バックグラウンドでサイトを開く --------------------
 
    'IEを起動する
    Set objIE = CreateObject("InternetExplorer.application")
    objIE.Visible = False 'IEの表示の有無、Trueは表示、Falseは非表示

    'URLを開く　日本ソフト販売株式会社の郵便番号検索
    objIE.Navigate "http://api.nipponsoft.co.jp/zipcode/?search=" & zipcode

    'IEを待機
    Do While objIE.ReadyState <> 4 Or objIE.Busy = True
        DoEvents
    Loop



    '文字列の取得 --------------------
    
    '住所の漢字を取得
    kanji(0) = objIE.document.getElementsByClassName("kanji")(1).outerTEXT
    kanji(1) = objIE.document.getElementsByClassName("kanji")(2).outerTEXT
    kanji(2) = objIE.document.getElementsByClassName("kanji")(3).outerTEXT

    '住所の読み方を取得
    kana(0) = objIE.document.getElementsByClassName("kana")(1).outerTEXT
    kana(1) = objIE.document.getElementsByClassName("kana")(2).outerTEXT
    kana(2) = objIE.document.getElementsByClassName("kana")(3).outerTEXT
 
    '町名がない場合、読み方に違う文字列が入るので削除
    If kanji(2) = "以下に掲載がない場合" Then
        kana(2) = ""
    End If
 
 
 
    '文字数差の計算 --------------------
    
    '市区町村と町域の頭の位置を揃える為に文字数差を取得
    space(0) = Len(kana(0)) - Len(kanji(0))
    space(1) = Len(kana(1)) - Len(kanji(1))
    space(2) = Len(kanji(0)) - Len(kana(0))
    space(3) = Len(kanji(1)) - Len(kana(1))
 
    'n個の全角スペースを変数に格納
    For i = 0 To 3
        n = space(i)
        space(i) = ""
        For j = 1 To n
            space(i) = space(i) & "　"
        Next j
     
        '単語間の区切りの為、スペースを1個追加
        space(i) = space(i) & "　"
    Next i
 
 
    '表示する文字を整える --------------------
 
    '読み方をひらがなに変換
    kana(0) = StrConv(kana(0), vbHiragana)
    kana(1) = StrConv(kana(1), vbHiragana)
    kana(2) = StrConv(kana(2), vbHiragana)
 
    'スペースを調整して表示を整える
    str = kanji(0) & space(0) & kanji(1) & space(1) & kanji(2) & vbCrLf & _
          kana(0) & space(2) & kana(1) & space(3) & kana(2)

    '戻値
    GetAddressYomi = str
 
 
 
    '終了処理 --------------------
    
    'IEを閉じる
    objIE.Quit
 
    'オブジェクト解除
    Set objIE = Nothing

    Exit Function


'エラー処理 --------------------
myError:
    Select Case Err.Number
 
    Case 91 '該当がない場合
 
        ans = MsgBox("該当がありません" & vbCrLf & "IEで検索結果のページを表示しますか？", vbYesNo)
     
        'はいの場合、サイトを表示
        If ans = vbYes Then
            'IEを起動
            Set objIE = CreateObject("InternetExplorer.application")
            objIE.Visible = True 'IEの表示の有無、Trueは表示、Falseは非表示
     
            'URLを開く
            objIE.Navigate "http://api.nipponsoft.co.jp/zipcode/?search=" & zipcode
     
            'IEを待機
            Do While objIE.ReadyState <> 4 Or objIE.Busy = True
                DoEvents
            Loop
        End If

    Case Else
        MsgBox "エラー番号:" & Err.Number & vbCrLf & _
               "エラー内容:" & Err.Description
             
    End Select
 
End Function