VBA amacoda

郵便番号を住所に変換するプログラム – プログラムとデータを分けるメリット

ZIP To Address Converter – Separate Data From Program in VBA

 

はじめに

・動作は無保証です。
・Excel 2016 + Windows 10、Excel 2010 + Windows 7で動作確認しています。
・ファイルはここからダウンロードしてください。
・今回は、複数ファイルですので、Zipファイルに圧縮しています。
・パスワードはかけていませんので、そのまま展開してお使いください。
・元となるデータは、住所データのダウンロードサイト【住所.jp】さんの住所データCSVファイル（全国版）を利用しています。ありがとうございます。

今回は郵便番号を住所に変換するプログラムです。

郵便番号を入力してEnterを押すと、自動的に住所と住所のカナの一部を表示することができます。

ワークシート関数を使っていないので、セルに表示された住所とカナはすぐにコピペすることができます。追加で地番等を入力することもカンタンです。

 

このプログラムは

会社で開発しました。

【住所.jp】さんのデータは月1回更新されています。そのたびに手作業で整形するのは大変なので、自動整形できるように対応しました。

また、ワークシート関数を用いて郵便番号を住所に変換するのはカンタンですが、会社でのニーズが表示された住所の一部の続きに地番等を入力していきたいということでしたので、プログラムを用いて文字列をセルに表示するようにしました。

正しく郵便番号を入力すると、上の図のように住所の一部とそのカナが表示されます。

今回は郵便番号記入欄を「D3（R3C4）」セルに、住所表示欄を「D4（R4C4）」セルに、カナ表示欄を「D5（R5C4）」セルにしました。しかし、プログラムの該当部分を書き換えれば、ご自分のお好みのセルを利用することができます。

 

プログラムとデータを分けるメリットとは

このプログラムはZIPToAddressConverter.xlsmというプログラムファイルと、zenkoku.xlsmというデータファイルの2つのファイルから成ります。

プログラムとデータを分けると、プログラムは複雑になります。これはデメリットです。しかし、それはこのプログラムを利用するユーザには関係ありません。

プログラムとデータを分けると、
・プログラムのブックが軽くなります。
・複数のプログラムで同じデータを使いまわすことができます。
・データの更新は1つのデータファイルを更新すればすみます。
これはすべての人にとって大きなメリットです。

本プログラムでいえば、ZIPToAddressConverter.xlsmに含まれるZipToAddressシートをさまざまな申込書・報告書・届出書などにすれば、1つのデータファイルzenkoku.xlsmで郵便番号と住所の入力をかんたんベンリにすることができます。

以上のように、メリットとデメリットを比較してみると、プログラムとデータの分離のメリットのほうが大きいといえます。

でも、プログラムとデータを分離したサンプルは少ない

しかし、Web上では、なかなかプログラムとデータを分離したサンプル（分離サンプル）にはなかなかお目にかかりません。

なぜ、そうなのかといえば、いくつか理由があります。
・プログラムとデータを一体化したサンプル（一体化サンプル）のほうが説明しやすい。
・分離サンプルは考えるのがメンドウ。
・一体化サンプルにサイト閲覧者が慣れているので、分離サンプルを掲げるメリットがない。
・私たち一般事務職でない専業プログラマは複数言語を扱えるので、分離サンプルをあえてVBAで作る動機がない。
などなど。

プログラムとデータは分けるべき?

今回の場合、プログラムファイルのZipToAddressシートは申込書・報告書・届出書などになることを想定しています。

そのような場合には、数多くの書類を扱うことが考えられますので、プログラムとデータを分けるべきでしょう。

また、逆にそもそもデータがたくさんあって、それらを統括する立場でプログラムを構築する場合は、おのずからプログラムとデータは分離されるでしょうね。
・毎月の売上明細ファイル12個（1年分）を集計して、地域別・支店別・担当者別などに数字を分類して、最終成果物を作る
などの場合が考えられます。

 

このプログラムの構成はどうなっているのか?

このプログラムはZIPToAddressConverter.xlsmというプログラムファイルと、zenkoku.xlsmというデータファイルの2つのファイルから成ります。

2つのファイルがありますが、それぞれにプログラムが記述されています。

プログラムファイルであるZIPToAddressConverter.xlsmには、ThisWorkbookモジュールと、Sheet1（ZipToAddress）モジュールにプログラムが記述されています。標準モジュールは使用せず、すべてイベントプロシージャとそのサブプロシージャとして記述されています。郵便番号から住所とカナの一部を表示するプログラムです。

データファイルであるzenkoku.xlsmには、標準モジュールにプログラムが記述されています。郵便番号・住所データは1カ月に1回更新されますので、Web上から取得したデータを整形・保存するプログラムです。

 

プログラムファイルのソースコード

ZIPToAddressConverter.xlsmのソースコードです。

ThisWorkbookモジュールと、Sheet1（ZipToAddress）モジュールにソースコードがあります。

ThisWorkbookモジュールのソースコード

Option Explicit

Private Sub Workbook_Open()
    If F_CheckUpFile = False Then
        Workbooks.Open Filename:="zenkoku.xlsm", ReadOnly:=True
        ActiveWindow.Visible = False
    End If
End Sub

Private Function F_CheckUpFile() As Boolean
    If Dir(ThisWorkbook.Path & "\zenkoku.xlsm") = "" Then
        MsgBox "郵便番号・住所データファイルが" & _
               "同じフォルダに存在しません。", vbExclamation
        F_CheckUpFile = True
        Exit Function
    End If

    Dim myfile As Workbook

    For Each myfile In Workbooks
        With myfile
            If .Name = "zenkoku.xlsm" Then
                .Activate
                .ChangeFileAccess xlReadOnly
                ActiveWindow.Visible = False
                F_CheckUpFile = True
                Exit Function
            End If
        End With
    Next myfile
End Function

Private Sub Workbook_BeforeClose(Cancel As Boolean)
    Application.DisplayAlerts = False

    Dim myfile As Workbook

    For Each myfile In Workbooks
        If myfile.Name = "zenkoku.xlsm" Then
            myfile.Close
            Exit For
        End If
    Next myfile

    Application.DisplayAlerts = True

    If Workbooks.Count = 1 Then
        Application.Quit
    End If
End Sub

Sheet1（ZipToAddress）モジュールのソースコード

Option Explicit

Private Sub Worksheet_Change(ByVal Target As Range)
    If Not Intersect(Target, Cells(3, 4)) Is Nothing Then
        Select Case Len(Cells(3, 4).Value)
            Case 8
                If F_CheckUpZip = False Then Exit Sub
                If F_CheckUpBook = False Then Exit Sub
                If F_CheckUpSheet = False Then Exit Sub
                Call S_DisplayAddress
            Case 0
                Range(Cells(4, 4), Cells(5, 4)).Value = ""
            Case Else
                Call S_ClearWorksheet
        End Select
    End If
End Sub

Private Function F_CheckUpZip() As Boolean
    F_CheckUpZip = True

    Dim myZip As String: myZip = Cells(3, 4).Value

    Dim i As Long

    For i = 1 To 8
        Dim myDigit As String: myDigit = Mid(myZip, i, 1)

        Select Case i
            Case 4
                If myDigit <> "-" Then
                    F_CheckUpZip = False
                    Call S_ClearWorksheet
                    Exit For
                End If
            Case Else
                Dim myNumber As Long: myNumber = Asc(myDigit)

                If myNumber < 48 Or myNumber > 57 Then
                    F_CheckUpZip = False
                    Call S_ClearWorksheet
                    Exit For
                End If
        End Select
    Next i
End Function

Private Function F_CheckUpBook() As Boolean
    F_CheckUpBook = True

    On Error Resume Next

    Dim wbZip As Workbook: Set wbZip = Workbooks("zenkoku.xlsm")

    If wbZip Is Nothing Then
        F_CheckUpBook = False
        MsgBox """zenkoku.xlsm""ファイルがありません。" & _
               "このファイルを再起動してください。", vbExclamation
        Exit Function
    End If

    On Error GoTo 0

    Set wbZip = Nothing
End Function

Private Function F_CheckUpSheet() As Boolean
    F_CheckUpSheet = True

    Dim wbZip As Workbook: Set wbZip = Workbooks("zenkoku.xlsm")

    On Error Resume Next

    Dim wsZip As Worksheet: Set wsZip = wbZip.Worksheets("zenkoku")

    If wsZip Is Nothing Then
        wbZip = Nothing
        F_CheckUpSheet = False
        MsgBox """zenkoku""シートがありません。", vbExclamation
        Exit Function
    End If

    On Error GoTo 0

    Set wsZip = Nothing: Set wbZip = Nothing
End Function

Private Sub S_DisplayAddress()
    On Error GoTo HandleError

    Dim wbZip As Workbook: Set wbZip = Workbooks("zenkoku.xlsm")
    Dim wsZip As Worksheet: Set wsZip = wbZip.Worksheets("zenkoku")
    Dim wsAddress As Worksheet: Set wsAddress = Worksheets("ZipToAddress")

    With wsZip
        Dim myRow As Long: myRow = .Cells(.Rows.Count, 1).End(xlUp).Row
        Dim myZip As String: myZip = wsAddress.Cells(3, 4).Value

        Dim myCell As Range
        Set myCell = .Cells(WorksheetFunction.Match(myZip, _
                     .Range(.Cells(2, 1), .Cells(myRow, 1)), 0) + 1, 1)
        myRow = myCell.Row
    End With

    With wsAddress
        .Cells(4, 4).Value = wsZip.Cells(myRow, 2).Value
        .Cells(5, 4).Value = wsZip.Cells(myRow, 3).Value
    End With

    Set wsAddress = Nothing: Set wsZip = Nothing

    Exit Sub
HandleError:
    Call S_ClearWorksheet
End Sub

Private Sub S_ClearWorksheet()
    MsgBox "郵便番号が正しくありません。" & vbCrLf & _
           "正しい形式「123-4567」（ハイフンあり）で" & vbCrLf & _
           "入力してください。", vbExclamation
    Range(Cells(3, 4), Cells(5, 4)).Value = ""
    Cells(3, 4).Activate
End Sub

 

データファイルのソースコード

zenkoku.xlsmファイルのソースコードです。

Option Explicit

Sub S_CreateZIPToAddressTable_Main()
    Switch = True

    Dim myWB As Workbook

    Select Case F_CheckUpFile
        Case 0
            Exit Sub
        Case 1
            Set myWB = Workbooks("zenkoku.csv")
        Case 2
            Set myWB = _
                Workbooks.Open(ThisWorkbook.Path & "\zenkoku.csv")
    End Select

    If F_CheckUpSheet(myWB) = False Then Exit Sub

    Call S_CreateZIPToAddressTable_Core(myWB)

    Set myWB = Nothing

    Switch = False

    MsgBox "データ更新終了！", vbInformation
End Sub

Private Property Let Switch(ByVal Flag As Boolean)
  With Application
    .ScreenUpdating = Not Flag
    .EnableEvents = Not Flag
    .DisplayAlerts = Not Flag
    .Calculation = _
        IIf(Flag, xlCalculationManual, xlCalculationAutomatic)
    .PrintCommunication = Not Flag
  End With
End Property

Private Function F_CheckUpFile() As Long
    If Dir(ThisWorkbook.Path & "\zenkoku.csv") = "" Then
        MsgBox "郵便番号・住所データのCSVファイルが" & _
               "同じフォルダに存在しません。", vbExclamation
        F_CheckUpFile = 0
        Exit Function
    End If

    On Error Resume Next

    Dim myFile As Workbook

    For Each myFile In Workbooks
        If myFile.Name = "zenkoku.csv" Then
            F_CheckUpFile = 1
            Exit For
        Else
            F_CheckUpFile = 2
        End If
    Next myFile
End Function

Private Function F_CheckUpSheet(ByVal myWB As Workbook) As Boolean
    With myWB
        Dim myWS As Worksheet

        For Each myWS In .Worksheets
            If myWS.Name = "zenkoku" Then
                F_CheckUpSheet = True
                Exit For
            End If
        Next myWS
    End With

    If F_CheckUpSheet = False Then
        MsgBox "シート名が""zenkoku""になっていません" & vbCrLf & _
               "シート名を""zenkoku""にしてください。", _
               vbExclamation
    End If
End Function

Private Sub S_CreateZIPToAddressTable_Core(ByVal myWB As Workbook)
    With myWB.Worksheets("zenkoku")
        .Columns(22).Delete
        .Columns(18).Delete
        .Range(.Columns(14), .Columns(15)).Delete
        .Range(.Columns(1), .Columns(4)).Delete

        Dim myRow As Long: myRow = .Cells(.Rows.Count, 1).End(xlUp).Row

        .Cells(2, 15).Formula = _
            "=IF(B2=0,D2&F2&H2&J2,IF(B2=1,D2&F2&N2&"" ""&L2,""""))"
        .Cells(2, 16).Formula = _
            "=IF(B2=0,E2&G2&I2&K2,IF(B2=1,E2&G2&"" ""&M2,""""))"

        .Range(.Cells(2, 15), .Cells(2, 16)).Copy _
            Destination:=.Range(.Cells(3, 15), .Cells(myRow, 16))

        With Application
            .Calculation = xlCalculationAutomatic
            .Calculation = xlCalculationManual
        End With

        With .Range(.Cells(2, 15), .Cells(myRow, 16))
            .Copy
            .PasteSpecial Paste:=xlPasteValues
        End With

        .Range(.Columns(2), .Columns(14)).Delete
        .Range(.Columns(2), .Columns(3)).ColumnWidth = 70
        .Cells(1, 2).Value = "住所"
        .Cells(1, 3).Value = "住所カナ"
    End With

    Call S_ReplaceZeroToNothing(myWB)

    Call S_FreezePanes(myWB)

    Call S_CopyTable(myWB)
End Sub

Private Sub S_ReplaceZeroToNothing(ByVal myWB As Workbook)
    With myWB.Worksheets("zenkoku")
        Dim myRow As Long: myRow = .Cells(.Rows.Count, 1).End(xlUp).Row

        With .Range(.Cells(2, 3), .Cells(myRow, 3))
            .Replace What:="０１", Replacement:="１", LookAt:=xlPart
            .Replace What:="０２", Replacement:="２", LookAt:=xlPart
            .Replace What:="０３", Replacement:="３", LookAt:=xlPart
            .Replace What:="０４", Replacement:="４", LookAt:=xlPart
            .Replace What:="０５", Replacement:="５", LookAt:=xlPart
            .Replace What:="０６", Replacement:="６", LookAt:=xlPart
            .Replace What:="０７", Replacement:="７", LookAt:=xlPart
            .Replace What:="０８", Replacement:="８", LookAt:=xlPart
            .Replace What:="０９", Replacement:="９", LookAt:=xlPart
        End With
    End With
End Sub

Private Sub S_FreezePanes(ByVal myWB As Workbook)
    With myWB
        .Activate

        With .Worksheets("zenkoku")
            .Activate
            .Cells(2, 2).Activate
            ActiveWindow.FreezePanes = True
        End With
    End With
End Sub

Private Sub S_CopyTable(ByVal myWB As Workbook)
    With ThisWorkbook
        Dim myWS As Worksheet

        For Each myWS In .Worksheets
            If myWS.Name = "zenkoku" Then
                myWS.Delete
                Exit For
            End If
        Next myWS
    End With

    With myWB
        .Worksheets("zenkoku").Copy _
            Before:=ThisWorkbook.Worksheets("UpdateTable")
        .Close
    End With

    ThisWorkbook.Save
End Sub

 

ThisWorkbookモジュールのソースコードの解説

Workbook_Openサブプロシージャ

Private Sub Workbook_Open()
    If F_CheckUpFile = False Then
        Workbooks.Open Filename:="zenkoku.xlsm", ReadOnly:=True
        ActiveWindow.Visible = False
    End If
End Sub

このWorkbook_Openサブプロシージャは、ワークブックを開いたときに実行されるプロシージャで、通常はThisWorkbookモジュールに記述します。

そうすることで、このブックZIPToAddressConverter.xlsmを開いたときに上のコードを実行します。

その内容は、F_CheckUpFileファンクションプロシージャの戻り値がFalseのときにzenkoku.xlsmを読み取り専用で開き、開いたそのファイルを非表示にする、ということです。

Workbooks.Openメソッドの引数ReadonlyにTrueを設定すると、ファイルを読み取り専用で開きます。

参考までに、この引数ReadonlyにFalseを設定しても、もともとファイル属性に「読み取り専用属性」を設定されているファイルを、その属性を無視して、読み書きできる状態でファイルを開くわけではないので、注意が必要です。

もう1つ言えば、ファイルの読み取り専用属性を解除するにはビット演算が必要です。

ActiveWindow.VisibleプロパティにFalseを設定すると、zenkoku.xlsmを非表示にします。Windows("zenkoku.xlsm").Visible = Falseとしても、なぜか非表示にならなかったので、Windows("zenkoku.xlsm")の代わりにActiveWindowプロパティを使用しました。

F_CheckUpFileファンクションプロシージャ

Private Function F_CheckUpFile() As Boolean
    If Dir(ThisWorkbook.Path & "\zenkoku.xlsm") = "" Then
        MsgBox "郵便番号・住所データファイルが" & _
               "同じフォルダに存在しません。", vbExclamation
        F_CheckUpFile = True
        Exit Function
    End If

    Dim myFile As Workbook

    For Each myFile In Workbooks
        With myFile
            If .Name = "zenkoku.xlsm" Then
                .Activate
                .Save
                .ChangeFileAccess xlReadOnly
                ActiveWindow.Visible = False
                F_CheckUpFile = True
                Exit Function
            End If
        End With
    Next myfile
End Function

このファンクションプロシージャでは、データファイルであるzenkoku.xlsmの存在を調べ、開いているかどうかを確認します。

Dir関数は、ファイルが存在するかどうかを判定できる関数です。引数に指定したファイルが存在すると、Dir関数はファイル名を返します。存在しないときは長さ0の文字列""を返します。このとき、このファンクションプロシージャはTrueを返します。

続いて、現在開いているファイルの中にzenkoku.xlsmがないか確認します。

zenkoku.xlsmが存在したときは、まずブックをアクティブにして、次にChangeFileAccessメソッドを使用します。

ChangeFileAccessメソッドはブックのアクセス権を変更します。この場合は、「読み書き」自由なアクセス権を「読み取り専用」に変更するので、いったんファイルを閉じてから「読み取り専用」でzenkoku.xlsmブックを開きます。

つまり、

myFile.ChangeFileAccess xlReadOnly

は、

myFile.Close
Workbooks.Open Filename:=myFile, ReadOnly:=True

と同じ働きをします。

そうしておいて、zenkoku.xlsmブックを非表示にし、このプロシージャはTrueを返します。

また、どちらの条件にも該当しないときは、このプロシージャはFalseを返します。

Workbook_BeforeCloseサブプロシージャ

Private Sub Workbook_BeforeClose(Cancel As Boolean)
    Application.DisplayAlerts = False

    Dim myFile As Workbook

    For Each myFile In Workbooks
        If myFile.Name = "zenkoku.xlsm" Then
            myFile.Close
            Exit For
        End If
    Next myFile

    Application.DisplayAlerts = True

    If Workbooks.Count = 1 Then
        Application.Quit
    End If
End Sub

このプロシージャには、ZIPToAddressConverter.xlsmブックを閉じるときに同時にzenkoku.xlsmブックを閉じる処理を記述しています。

警告表示がでないようにApplication.DisplayAlertsも記述しておきます。

このブックを閉じると、たしかに同時にzenkoku.xlsmブックは閉じられますが、アプリケーションは終了せずに残っています。

そこでもう1つ処理を加えます。この時点で開いているファイルがこのブックだけのときは、アプリケーションを終了します。

 

Sheet1モジュールのソースコードの解説

Worksheet_Changeサブプロシージャ

Private Sub Worksheet_Change(ByVal Target As Range)
    If Not Intersect(Target, Cells(3, 4)) Is Nothing Then
        Select Case Len(Cells(3, 4).Value)
            Case 8
                If F_CheckUpZip = False Then Exit Sub
                If F_CheckUpBook = False Then Exit Sub
                If F_CheckUpSheet = False Then Exit Sub
                Call S_DisplayAddress
            Case 0
                Range(Cells(4, 4), Cells(5, 4)).Value = ""
            Case Else
                Call S_ClearWorksheet
        End Select
    End If
End Sub

Worksheet_Changeサブプロシージャは、Intersectメソッドと組み合わせることで、特定のセル範囲が変更されたときのみ処理を実行することができます。

Intersectメソッドは、引数に指定したセル範囲の中で共通するセル範囲を表すRangeオブジェクトを返します。共通部分が無い場合は、Nothingを返します。

また、ワークシートのChangeイベントでは、変更されたセル範囲を表すRangeオブジェクトが引数Targetに渡されます。これらを利用して、特定のセル範囲が変更されたときのみ処理を実行するマクロを作成します。

このプロシージャでは、Not Intersect(Target, Cells(3, 4)) Is Nothingで、変更のあったセルと「D3（R3C4）」セルに共通範囲がないときを否定して、つまりNot Intersect(Target, Cells(3, 4)) Is Nothingで、変更のあったセルと「D3（R3C4）」セルに共通範囲があるときにプロシージャを実行します。

Notは、論理演算子で

Not A

A全体を否定します。この場合、

Intersect(Target, Cells(3, 4)) Is Nothing

を否定します。

「D3（R3C4）」セルに変更があった場合、「D3（R3C4）」セルの値の文字数によって、処理を分岐しています。

「D3（R3C4）」セルの値の文字数が8文字、例えば「123-4567」という郵便番号の形式の場合、F_CheckUpZip、F_CheckUpBook、F_CheckUpSheetという3つのファンクションプロシージャを処理し、住所を表示するS_DisplayAddressサブプロシージャを実行します。

「D3（R3C4）」セルの値の文字数が0文字、つまりセルが空白の場合、「D4（R4C4）」セルと「D5（R4C5）」セルを空白にします。

「D3（R3C4）」セルの値の文字数がそれ以外の場合、「D3（R3C4）」セル・「D4（R4C4）」セル・「D5（R4C5）」セルの、3つのセルを空白にするS_ClearWorksheetサブプロシージャを実行します。

F_CheckUpZipファンクションプロシージャ

Private Function F_CheckUpZip() As Boolean
    F_CheckUpZip = True

    Dim myZip As String: myZip = Cells(3, 4).Value

    Dim i As Long

    For i = 1 To 8
        Dim myDigit As String: myDigit = Mid(myZip, i, 1)

        Select Case i
            Case 4
                If myDigit <> "-" Then
                    F_CheckUpZip = False
                    Call S_ClearWorksheet
                    Exit For
                End If
            Case Else
                Dim myNumber As Long: myNumber = Asc(myDigit)

                If myNumber < 48 Or myNumber > 57 Then
                    F_CheckUpZip = False
                    Call S_ClearWorksheet
                    Exit For
                End If
        End Select
    Next i
End Function

このプロシージャでは、「D3（R3C4）」セルに入力した郵便番号の値が正しいかどうかチェックします。

前段階のWorksheet_Changeサブプロシージャでは、セルに入力された値の文字数が8文字かどうかしかチェックすることができませんでした。

ここでは、For文を使って、1文字1文字チェックしています。

セルの値の4文字目が-以外の場合はS_ClearWorksheetでセルの値をクリアします。

セルの値の1～3文字目・5～8文字目の場合は1から9までの数字かどうかチェックして、それ以外の文字が含まれる場合はS_ClearWorksheetでセルの値をクリアします。

Asc関数は、指定した文字の文字コード（Shift_JIS）を返します。

0という文字の文字コードは48、1、2、と順番に、9の文字コードは57になります。

したがって、戻り値の文字コードが48より小さいか、57より大きい場合は0～9の数字ではありませんので、S_ClearWorksheetでセルの値をクリアします。

F_CheckUpBookファンクションプロシージャ

Private Function F_CheckUpBook() As Boolean
    F_CheckUpBook = True

    On Error Resume Next

    Dim wbZip As Workbook: Set wbZip = Workbooks("zenkoku.xlsm")

    If wbZip Is Nothing Then
        F_CheckUpBook = False
        MsgBox """zenkoku.xlsm""ファイルがありません。" & _
               "この""ZIPToAddressConverter.xlsm""ファイルを" & _
               "再起動してください。", vbExclamation
        Exit Function
    End If

    On Error GoTo 0

    Set wbZip = Nothing
End Function

ここでは、zenkoku.xlsmが開いているかどうかだけをチェックしています。

そのほかに関連する作業をするわけではないので、変数wbZipにzenkoku.xlsmをセットします。

zenkoku.xlsmが開かれていれば、何事もなく変数wbZipにセットされます。

しかし、zenkoku.xlsmが開かれていなければ、エラーが発生し、変数wbZipには初期値のNothingがセットされたままです。

これをIf文を使ってチェックしています。

その場合、ZIPToAddressConverter.xlsmを再起動するようメッセージでうながしています。このファイルを再起動すれば、自動的にzenkoku.xlsmも起動されるからです。

F_CheckUpSheetファンクションプロシージャ

Private Function F_CheckUpSheet() As Boolean
    F_CheckUpSheet = True

    Dim wbZip As Workbook: Set wbZip = Workbooks("zenkoku.xlsm")

    On Error Resume Next

    Dim wsZip As Worksheet: Set wsZip = wbZip.Worksheets("zenkoku")

    If wsZip Is Nothing Then
        wbZip = Nothing
        F_CheckUpSheet = False
        MsgBox """zenkoku""シートがありません。", vbExclamation
        Exit Function
    End If

    On Error GoTo 0

    Set wsZip = Nothing: Set wbZip = Nothing
End Function

1つ前のプロシージャでzenkoku.xlsmが開かれていることが保証されているので、変数wbZipに確実にセットされます。

そこで、zenkokuシートを変数wsZipにセットしてみます。

1つ前のプロシージャと同じ仕組みで、zenkokuシートが存在しない場合、エラーが発生し、プログラムを終了します。

S_DisplayAddressサブプロシージャ

Private Sub S_DisplayAddress()
    On Error GoTo HandleError

    Dim wbZip As Workbook: Set wbZip = Workbooks("zenkoku.xlsm")
    Dim wsZip As Worksheet: Set wsZip = wbZip.Worksheets("zenkoku")
    Dim wsAddress As Worksheet: Set wsAddress = Worksheets("ZipToAddress")

    With wsZip
        Dim myRow As Long: myRow = .Cells(.Rows.Count, 1).End(xlUp).Row
        Dim myZip As String: myZip = wsAddress.Cells(3, 4).Value

        Dim myCell As Range
        Set myCell = .Cells(WorksheetFunction.Match(myZip, _
                     .Range(.Cells(2, 1), .Cells(myRow, 1)), 0) + 1, 1)
        myRow = myCell.Row
    End With

    With wsAddress
        .Cells(4, 4).Value = wsZip.Cells(myRow, 2).Value
        .Cells(5, 4).Value = wsZip.Cells(myRow, 3).Value
    End With

    Set wsAddress = Nothing: Set wsZip = Nothing

    Exit Sub
HandleError:
    Call S_ClearWorksheet
End Sub

プログラムシートのZipToAddressの「D3（R4C3）」セルに入力した郵便番号の文字列を、zenkoku.xlsmブックのzenkokuシートから検索して、プログラムシートのZipToAddressの「D4（R4C4）」セルに住所を、「D5（R5C4）」セルに住所のカナを入力します。

シートの検索方法は、Findメソッドではなく、ワークシート関数のMatch関数を使います。

理由は、次のページに詳細に書かれていますので、ご一読ください。

エクセルの神髄 – トップ > マクロVBA > マクロVBA技術解説 > VBAのFindメソッドの使い方には注意が必要です

このプログラムの住所データは約15万件です。zenkoku.xlsmブックのzenkokuシート上でCtrl + Fを押して、郵便番号を検索するとわかりますが、一瞬のタイムラグがあります。一回だけなら気にもなりませんが、何回も郵便番号を検索する場合、気になるレベルです。これは、プログラムでFindメソッドを使っても同じことです。

そこでMatch関数の出番です。Match関数は、範囲内から指定した値を探して、範囲内の上から数えた位置を求める関数です。これなら、ほとんどタイムラグがありません。

ここでの検索範囲は2行目からmyRow行目です。

範囲内の上から数えた位置が1番目ならば、行数は2です。同様に、位置がmyRow - 1ならば、行数はmyRowです。

欲しいのは範囲内の位置ではなく、セルの行数ですので、Match関数の答えに1を加え、行数を求めます。

そうしてようやく、検索する郵便番号のセル番地が求められます。

そのセル番地の隣が住所の文字列、またその隣が住所のカナの文字列です。

その文字列を、それぞれ「D4（R4C4）」セルに住所を、「D5（R5C4）」セルに住所のカナを入力します。

S_ClearWorksheetサブプロシージャ

Private Sub S_ClearWorksheet()
    MsgBox "郵便番号が正しくありません。" & vbCrLf & _
           "正しい形式「123-4567」（ハイフンあり）で" & vbCrLf & _
           "入力してください。", vbExclamation
    Range(Cells(3, 4), Cells(5, 4)).Value = ""
    Cells(3, 4).Activate
End Sub

エラーが発生した場合に、エラーメッセージを表示して、「D3（R3C4）」セルから「D5（R5C4）」セルを空白にします。

 

mdlCreateZIPToAddressTable標準モジュールのソースコードの解説

このモジュールに記述されているプログラムは、郵便番号・住所データを更新するプログラムです。

住所データのダウンロードサイト【住所.jp】さんの住所データCSVファイル（全国版）は素晴らしくわかりやすいデータですが、そのままでは、当方の目的に合致しません。

また、郵便番号・住所データは月に1回更新されますので、毎回手作業で更新するのは大変です。

したがって、このプログラムでデータの自動更新をおこないます。

S_CreateZIPToAddressTable_Mainサブプロシージャ

Sub S_CreateZIPToAddressTable_Main()
    Switch = True

    Dim myWB As Workbook

    Select Case F_CheckUpFile
        Case 0
            Exit Sub
        Case 1
            Set myWB = Workbooks("zenkoku.csv")
        Case 2
            Set myWB = _
                Workbooks.Open(ThisWorkbook.Path & "\zenkoku.csv")
    End Select

    If F_CheckUpSheet(myWB) = False Then Exit Sub

    Call S_CreateZIPToAddressTable_Core(myWB)

    Set myWB = Nothing

    Switch = False

    MsgBox "データ更新終了！", vbInformation
End Sub

本プログラムのメインプログラムです。データ更新の全体をコントロールします。

Switchプロパティプロシージャでプログラムの高速化・自動化を図り、F_CheckUpFileファンクションプロシージャの戻り値によって、プログラムを終了するかどうかを判定し、継続するときは変数myWBにzenkoku.csvをセットし、F_CheckUpSheetファンクションプロシージャの戻り値がTrueならば、本プログラムの中心のS_CreateZIPToAddressTable_Coreサブプロシージャを実行します。

Switchプロパティプロシージャ

Private Property Let Switch(ByVal Flag As Boolean)
  With Application
    .ScreenUpdating = Not Flag
    .EnableEvents = Not Flag
    .DisplayAlerts = Not Flag
    .Calculation = _
        IIf(Flag, xlCalculationManual, xlCalculationAutomatic)
    .PrintCommunication = Not Flag
  End With
End Property

このブログでは何回も出ているプロパティプロシージャですが、主にプログラムの高速化・自動化のために使用しています。

ScreenUpdating・EnableEvents・Calculation・PrintCommunicationはプログラムの高速化のために、DisplayAlertsはプログラムの自動化のために設定しています。

F_CheckUpFileファンクションプロシージャ

Private Function F_CheckUpFile() As Long
    If Dir(ThisWorkbook.Path & "\zenkoku.csv") = "" Then
        MsgBox "郵便番号・住所データのCSVファイルが" & _
               "同じフォルダに存在しません。", vbExclamation
        F_CheckUpFile = 0
        Exit Function
    End If

    Dim myFile As Workbook

    For Each myFile In Workbooks
        If myFile.Name = "zenkoku.csv" Then
            F_CheckUpFile = 1
            Exit For
        Else
            F_CheckUpFile = 2
        End If
    Next myFile
End Function

Dir関数で郵便番号・住所データのCSVファイルが存在するかどうかを確認し、存在しない場合、変数F_CheckUpFileに0を代入し、本プログラム全体を終了します。

開いているブックの中にzenkoku.csvが存在する場合は、変数F_CheckUpFileに1を代入し、存在しない場合は、変数F_CheckUpFileに2を代入します。

いずれもメインプログラムに戻ったときに、変数myWBにzenkoku.csvをセットするための作業です。

メインプログラムに戻ったときに、zenkoku.csvが開いていれば、そのまま変数myWBにzenkoku.csvをセットし、開いていなければ、開いてから変数myWBにzenkoku.csvをセットします。

F_CheckUpSheetファンクションプロシージャ

Private Function F_CheckUpSheet(ByVal myWB As Workbook) As Boolean
    With myWB
        Dim myWS As Worksheet

        For Each myWS In .Worksheets
            If myWS.Name = "zenkoku" Then
                F_CheckUpSheet = True
                Exit For
            End If
        Next myWS
    End With

    If F_CheckUpSheet = False Then
        MsgBox "シート名が""zenkoku""になっていません" & vbCrLf & _
               "シート名を""zenkoku""にしてください。", _
               vbExclamation
    End If
End Function

開いたシートがzenkokuシートになっているかどうかを確認し、なっていなければプログラムを終了します。

S_CreateZIPToAddressTable_Coreサブプロシージャ

Private Sub S_CreateZIPToAddressTable_Core(ByVal myWB As Workbook)
    With myWB.Worksheets("zenkoku")
        .Columns(22).Delete
        .Columns(18).Delete
        .Range(.Columns(14), .Columns(15)).Delete
        .Range(.Columns(1), .Columns(4)).Delete

        Dim myRow As Long: myRow = .Cells(.Rows.Count, 1).End(xlUp).Row

        .Cells(2, 15).Formula = _
            "=IF(B2=0,D2&F2&H2&J2,IF(B2=1,D2&F2&N2&"" ""&L2,""""))"
        .Cells(2, 16).Formula = _
            "=IF(B2=0,E2&G2&I2&K2,IF(B2=1,E2&G2&"" ""&M2,""""))"

        .Range(.Cells(2, 15), .Cells(2, 16)).Copy _
            Destination:=.Range(.Cells(3, 15), .Cells(myRow, 16))

        With Application
            .Calculation = xlCalculationAutomatic
            .Calculation = xlCalculationManual
        End With

        With .Range(.Cells(2, 15), .Cells(myRow, 16))
            .Copy
            .PasteSpecial Paste:=xlPasteValues
        End With

        .Range(.Columns(2), .Columns(14)).Delete
        .Range(.Columns(2), .Columns(3)).ColumnWidth = 70
        .Cells(1, 2).Value = "住所"
        .Cells(1, 3).Value = "住所カナ"
    End With

    Call S_ReplaceZeroToNothing(myWB)

    Call S_FreezePanes(myWB)

    Call S_CopyTable(myWB)
End Sub

データ更新プログラムの中心部分。主にデータの整形をおこないます。

不要行を削除する

zenkoku.csvの新住所ＣＤ・補足・町域補足・京都通り名・住所ＣＤ・都道府県ＣＤ・市区町村ＣＤ・町域ＣＤの各フィールドを削除します。必要な各フィールドを結合するために不要なフィールドを削除します。

各フィールドを結合する式を代入する

zenkoku.csvの郵便番号・住所データをよく見てみると、データの書式が、事業所フラグ＝０、すなわち事業所でない一般家庭などの普通の住所の場合と、事業所フラグ＝１、すわなち事業所の住所の場合で、異なることがわかります。

ですので、それに応じて各フィールドを結合する式を変更します。

事業所フラグ＝０の場合に漢字住所を取得するには、D2&F2&H2&J2として、都道府県・市区町村・町域・字丁目の各フィールドを結合します。

事業所フラグ＝１の場合に漢字住所を取得するには、D2&F2&N2&"" ""&L2として、都道府県・市区町村・事業所住所・事業所名の各フィールドを結合します。

事業所フラグ＝０の場合にカナ住所を取得するには、E2&G2&I2&K2として、都道府県カナ・市区町村カナ・町域カナ・字丁目カナの各フィールドを結合します。

事業所フラグ＝１の場合にカナ住所を取得するには、E2&G2&"" ""&M2として、都道府県カナ・市区町村カナ・事業所名カナの各フィールドを結合します。

以上のような場合分けをIf文でおこなって、O2（R2C15）セルに漢字住所を求める式を、P2（R2C16）セルにカナ住所を求める式を代入します。

一番やってはいけないことは

For ～ Next文でループを回して、各セルに「式」ではなく、「値」を代入するやり方です。

次のようなコードがよくありません。

Dim i As Long

For i = 2 To myRow
    If .Cells(i, 2).Value = 0 Then
        .Cells(i, 15).Value = .Cells(i, 4).Value & .Cells(i, 6).Value & _
                              .Cells(i, 8).Value & .Cells(i, 10).Value
        .Cells(i, 16).Value = .Cells(i, 5).Value & .Cells(i, 7).Value & _
                              .Cells(i, 9).Value & .Cells(i, 11).Value
    ElseIf .Cells(i, 2).Value = 1 Then
        .Cells(i, 15).Value = .Cells(i, 4).Value & .Cells(i, 6).Value & _
                              .Cells(i, 14).Value & .Cells(i, 12).Value
        .Cells(i, 16).Value = .Cells(i, 5).Value & .Cells(i, 7).Value & _
                              .Cells(i, 13).Value
    End If
Next i

コードはわかりやすく、間違いもなく、一見いいコードに見えますが、目に見えないところで決定的にダメな点があります。

実行速度がとてつもなく遅いという点です。

私の環境では、2～3分かかりました。

2～3分あれば、O2（R2C15）セルに漢字住所を求める式をP2（R2C16）セルにカナ住所を求める式を手入力し、その他のセルに式をコピーして、エクセルが再計算し、さらに全セルを選択してコピーし、値を貼り付けしても、まだ時間が余ります。

ですので、手入力よりも遅いプログラムを書いてはいけない、ということです。

逆にいえば、今書いた、手入力の部分をプログラムに記述すればよい、ということです。

式をその他のセルに貼り付け、再計算し、値を求める

ここで説明するのは、次のコードです

.Range(.Cells(2, 15), .Cells(2, 16)).Copy _
    Destination:=.Range(.Cells(3, 15), .Cells(myRow, 16))

With Application
    .Calculation = xlCalculationAutomatic
    .Calculation = xlCalculationManual
End With

With .Range(.Cells(2, 15), .Cells(myRow, 16))
    .Copy
    .PasteSpecial Paste:=xlPasteValues
End With

zenkoku.csvのO2（R2C15）セルとP2（R2C16）セルの住所を求める式を、3行目から最終行までコピーします。

次に再計算の方法を、いったん手動から自動に変更し、ふたたび自動から手動に変更しています。

この記述は必要でしょうか?

実は、Switchプロパティプロシージャで再計算の方法を手動にしていますので、式をコピーしただけでは3行目から最終行までのセルでは、セルに正しい結果が表示されないのです。

そこで、いったん再計算方法を自動にする必要があるのです。自動にすれば、その場で再計算がされます。その後、再び再計算方法を手動に戻します。

再計算が終われば正しい値が表示されますので、全セルを選択し、式ではなく、値を貼り付けます。

これが最速のやり方です。

余分な列を削除し、書式を整える

.Range(.Columns(2), .Columns(14)).Delete
.Range(.Columns(2), .Columns(3)).ColumnWidth = 70
.Cells(1, 2).Value = "住所"
.Cells(1, 3).Value = "住所カナ"

zenkoku.csvのB列からN列を削除し、その後B列とC列の幅を「70」に設定し、B1（R1C2）セルとC1（R1C3）セルに住所という文字列と住所カナという文字列を代入します。

この後は、3つのサブプロシージャを呼び出し、実行します。

S_ReplaceZeroToNothingサブプロシージャ

Private Sub S_ReplaceZeroToNothing(ByVal myWB As Workbook)
    With myWB.Worksheets("zenkoku")
        Dim myRow As Long: myRow = .Cells(.Rows.Count, 1).End(xlUp).Row

        With .Range(.Cells(2, 3), .Cells(myRow, 3))
            .Replace What:="０１", Replacement:="１", LookAt:=xlPart
            .Replace What:="０２", Replacement:="２", LookAt:=xlPart
            .Replace What:="０３", Replacement:="３", LookAt:=xlPart
            .Replace What:="０４", Replacement:="４", LookAt:=xlPart
            .Replace What:="０５", Replacement:="５", LookAt:=xlPart
            .Replace What:="０６", Replacement:="６", LookAt:=xlPart
            .Replace What:="０７", Replacement:="７", LookAt:=xlPart
            .Replace What:="０８", Replacement:="８", LookAt:=xlPart
            .Replace What:="０９", Replacement:="９", LookAt:=xlPart
        End With
    End With
End Sub

S_CreateZIPToAddressTable_Coreサブプロシージャから呼び出され、zenkoku.csvの上で実行されます。

このプロシージャが何をおこなっているかというと、「住所カナ」を保持しているC列に「０１チョウメ」～「０９チョウメ」という表記があるので、それを「１チョウメ」～「９チョウメ」という表記に置き換えています。

S_FreezePanesサブプロシージャ

Private Sub S_FreezePanes(ByVal myWB As Workbook)
    With myWB
        .Activate

        With .Worksheets("zenkoku")
            .Activate
            .Cells(2, 2).Activate
            ActiveWindow.FreezePanes = True
        End With
    End With
End Sub

上のS_ReplaceZeroToNothingサブプロシージャと同じく、S_CreateZIPToAddressTable_Coreサブプロシージャから呼び出され、zenkoku.csvの上で実行されます。

zenkokuシートのB2（R2C2）セルを選択し、ウィンドウ枠の固定化をおこなっています。

S_CopyTableサブプロシージャ

Private Sub S_CopyTable(ByVal myWB As Workbook)
    With ThisWorkbook
        Dim myWS As Worksheet

        For Each myWS In .Worksheets
            If myWS.Name = "zenkoku" Then
                myWS.Delete
                Exit For
            End If
        Next myWS
    End With

    With myWB
        .Worksheets("zenkoku").Copy _
            Before:=ThisWorkbook.Worksheets("UpdateTable")
        .Close
    End With

    ThisWorkbook.Save
End Sub

上のS_ReplaceZeroToNothingサブプロシージャと同じく、S_CreateZIPToAddressTable_Coreサブプロシージャから呼び出され、zenkoku.csvと、このワークブックZIPToAddressConverter.xlsm上で実行されます。

ZIPToAddressConverter.xlsm上にzenkokuシートがあれば削除し、zenkoku.csvから整形済みのzenkokuシートをZIPToAddressConverter.xlsmにコピーし、上書き保存します。

 

おわりに

今回は、郵便番号から住所の一部を検索して表示するというプログラムでしたが、複数ファイルへの応用を視野に入れて、プログラムとデータの分離をおこないました。

プログラムの利用方法・利用目的、ユーザのスキル、メンテナンスの難易度になどにより、プログラムとデータを分離したほうがよいかどうかは決まります。

みなさんも条件が合致すれば、プログラムとデータの分離を考えてみてください。

コメントを残す

RECOMMENDこちらの記事も人気です。