m-eye blog

ノンプログラマによるVBAとPythonの学習記録

郵便番号から住所を検索するマクロ(データ更新機能つき) - 不渡届その1

f:id:m-eye:20181019094618p:plain

 

郵便番号を入力すると住所の一部を表示するマクロ

セルに郵便番号を入力してEnterを押すと、該当する住所の一部とそのフリガナを表示するマクロを考えました。

たとえば、郵便番号のセルに「154-0001」とセルに入力してEnterを押すと、住所のセルに「東京都世田谷区池尻」と表示されるようなものです。

VLOOKUPのようなワークシート関数をつかうと超高速で表示されるのですが、実務上は「東京都世田谷区池尻」のあとに地番などを入力する必要があるので、関数はムリです。ちゃんと文字列が入力される必要があります。

そこでマクロをつかうことになりました。VLOOKUPと同じスピードを確保して、セルには検索の結果が数式ではなく、文字列で入力されるという条件は、マクロを使わないと満たせませんね。

  • ファイルはYahoo! ボックスに公開しているので、ここからダウンロードして自由につかってください。
  • 動作確認は、Offie 365 Solo + Windows 10でおこなっています。
  • 動作は無保証です。

 

この記事は

VBAの命令の1行1行はわかるけれども、いったいどう組み合わせたら実際に使えるマクロが書けるかわからない、と悩んでいる方にむけて書きました。

1つ1つはカンタンな命令しかないかもしれませんが、どう組み合わせるか、なにに配慮するかの例として読んでいただけたらと思います。

この記事は、かなり長いです。いろいろ説明を詰め込みすぎたかもしれません。

 

郵便番号データ

約15万件あり、日々更新されているのですが、便利なサイトがあったので、その公開データをもとに更新元となる郵便番号データを更新するマクロも同時に作成して、郵便番号データの陳腐化をふせぎます。

jusyo.jp

無料で郵便番号データを公開してくださっているありがたいサイトはいくつもありますが、このサイトもそのひとつです。ここにCSVファイルがありましたので、それをつかわせていただきます。ほかにもMDBファイルなどもありますが、ExcelであつかうにはCSVファイルがいいですね。

 

ワークシートの例として不渡届をえらびました

f:id:m-eye:20181019094618p:plain

ノンプログラマが実際の業務であつかうExcelの帳票にはいろいろあるとおもいますが、これもそのひとつです。

わたしの会社でもいままで手書きだった不渡届がようやくExcelのファイルになりました。もちろん、手形交換所にはいまでも手書きで提出しますが。

ワークシートはなんでもいいと思いますが、ただセルに入力するだけでは自分がおもしろくないので、Web上に公開されている一般財団法人静岡県銀行協会のこのPDF文書の不渡届をもとに自分でエクセルファイルを作成しました。

実際の業務でつかっている不渡届は社外に出せないので、作成したのはその一部で、例として入力してあるデータはまっかなウソです。架空のデータを入力しています。実在の方とはなんの関係もありません。

 

マクロの構成

f:id:m-eye:20181019174731p:plain

 

シートモジュールの郵便番号検索マクロ

実際に業務で使うマクロなので、パソコンにあまりくわしくないユーザへの気配りはかかせません。自分だけが使うわけではないので。

郵便番号を検索するマクロは、マクロを起動するトリガーが必要ですね。今回はボタンやショートカットにマクロを登録するのではなく、セルに郵便番号を入力して(セルの内容を変化させて)、Enterを押すとマクロが起動して、住所とフリガナを表示するようにします。

だから、そのマクロはセルの内容の変化を検知するイベントプロシージャになり、「NoticeOfDishonor」という名前のシートのシートモジュールに書きます。

 

ThisWorkbookモジュールのマクロ

パソコンにあまりくわしくないユーザは、ブックをひらいたときに、まずどのセルを操作するのか探すのが苦痛です。それをやわらげるために、このブックをひらいたときに、不渡届のシートを選択し、郵便番号のセルを選択しておきます。

 

標準モジュールのデータ更新マクロ

これは自分で使うか、インターネット参照権限を持った管理者が使う(わたしの部署のほとんどの人はインターネットの参照権限がないばかりか、自分専用のパソコンもありません)ので、イベントプロシージャにする必要はありません。シート上にボタンを配置するか、ショートカットを設定すればじゅうぶんです。今回はほかの管理者にも便利なようにシート上にボタンを配置することにしました。

 

シートモジュールの郵便番号検索イベントプロシージャ

ここでは、Worksheet_Changeイベントプロシージャをつかいます。Worksheet_SelectionChangeではセルの値に変化がなくても別のセルをクリックしただけでプロシージャが起動してしまいますので適切ではないですね。

 

ソースコード

Private Sub Worksheet_Change(ByVal Target As Range)
    Dim myCell As Range
    Dim myLf As Long
    Dim my1stValue As String, my2ndValue As String
    
    Select Case True
        Case Not Intersect(Target, Range("I13")) Is Nothing
            Set myCell = Range("I13")
            myLf = InStr(myCell.Value, vbLf)
            
            Select Case Len(myCell.Value)
                Case 8
                    If F_CheckUpZip(myCell.Value) = False _
                        Then Exit Sub
                    If F_CheckUpSheet = False _
                        Then Exit Sub
                    
                    Call S_DisplayAddress(myCell.Value)
                
                Case 17
                    If myLf > 0 Then
                        my1stValue = _
                            Left(myCell.Value, myLf - 1)
                        my2ndValue = _
                            Mid(myCell.Value, myLf + 1)
                        
                        If F_CheckUpZip(my1stValue) = _
                            False Then Exit Sub
                        If F_CheckUpZip(my2ndValue) = _
                            False Then Exit Sub
                        If F_CheckUpSheet = _
                            False Then Exit Sub
                        
                        Call S_DisplayAddress2( _
                            my1stValue, my2ndValue)
                            
                    Else
                        Call S_ClearWorksheet
                        
                    End If
                
                Case 0
                    Range("O12, P11").Value = ""
                    myCell.Activate
                 
                Case Else
                    Call S_ClearWorksheet
                    
            End Select
            
            Set myCell = Nothing
            
    End Select
    
End Sub

 

ソースコードの解説

 

「Worksheet_Change」プロシージャの使い方

 

「Intersect」プロパティの使い方

郵便番号を入力するセル「I13」の値が変化したときだけ、住所とフリガナを入力したいので、Intersectメソッドを使って、「Worksheet_Change」プロシージャの引数Targetにセル「I13」が含まれるかどうか判断します。

 

「Intersect」プロパティの基本
Intersect(Target, Range("I13"))

Intersectプロパティは「2つのRange型オブジェクトの引数TargetRange("I13")との間の共通範囲があるかどうか」、共通範囲があればそのRange型オブジェクトを、なければNothingを返します。

 

「Nothing」との比較
Intersect(Target, Range("I13")) Is Nothing

これは「2つのRange型オブジェクトの引数TargetRange("I13")との間の共通範囲がないこと(Nothing)」をしめしています。

 

接頭辞「Not」をつけると全体の否定になる
Not Intersect(Target, Range("I13")) Is Nothing

一方、先頭にNotをつけると、全体の意味を否定することになります。

ですから、これは「2つのRange型オブジェクトの引数TargetRange("I13")との間の共通範囲があること」をしめしています。

これがマクロを起動するトリガーになります。If文やSelect文といった条件文に、この条件をかけば、そのときマクロが起動します。

 

「If」文ではなく「Select」文をつかう

今回の条件は、「Range("I13")の値が変化すること」1つですから、次のように書いてもまちがいではありません。

Private Sub Worksheet_Change(ByVal Target As Range)
    If Not Intersect(Target, Range("I13")) Is Nothing
       'ここに実行する処理を書く
    End If
End Sub

でも、使わないのには理由があります。

2つ以上の条件になったときにElseIfを使いたくないからです。ほかにもっといい方法があるからなんです。

 

Private Sub Worksheet_Change(ByVal Target As Range)
    Select Case True
        Case Not Intersect(Target, Range("I13")) Is Nothing
           'ここに実行する処理を書く
    End Select
End Sub

ネストはIf文よりもSelect文を使ったほうが1つ深くなりますが、ソースは読みやすくなりますよね。とくに条件が3つ以上のときは積極的にSelect文を使用したほうがいいと思います。

このプログラムも最終的には3つ以上の条件を設ける予定なので、Select文で書いています。

 

'ふつうのSelect文
Select Case Not Intersect(Target, Range("I13")) Is Nothing
    Case True

'今回のSelect文
Select Case True
    case  Not Intersect(Target, Range("I13")) Is Nothing

ふつうのSelect文では、TrueFalseかの2種類しか判断できません。でも、今回のSelect文なら、判断したいセルの数だけ、条件をふやすことができ、複雑な判断が可能になっています。

 

変数の宣言

変数の宣言は、その変数を使用するまえであれば、プログラムの先頭でも、使用する直前でも、どちらでもかまいません。PythonなどのVBA以外の言語では使用する直前に宣言するのがふつうです。そこらへんについては、VBA界隈で有名な「t-hom」さんが次のような記事を書かれています。

thom.hateblo.jp

thom.hateblo.jp

できるだけ変数を使用する直前で宣言したほうがいいということですね。

Dim myCell As Range
Dim myLf As Long
Dim my1stValue As String, my2ndValue As String

でも、Select文を使って、判断条件を3つ以上にふやす予定なので、プロシージャの先頭で変数を宣言しています。

myCellは対象となるセルを格納するRange型変数です。

郵便番号は2段書きになることも予想されるので、それに対応するための変数も用意します。

myLfは2段書きになる場合の改行文字の位置を格納します。

my1stValuemy2ndValueは2段書きになった場合の、それぞれ、1段目の郵便番号と2段目の郵便番号の値を格納します。

 

郵便番号を入力するセルを変数「myCell」に代入

Set myCell = Range("I13")

このプログラムの場合、わざわざ郵便番号を入力するセルを変数に代入しなければならないほど複雑ではありませんが、判断条件であるCase節が3つ以上にふえることを見越して、リテラルであるRange("I13")は変数に代入して利用します。

気をつけるのは、使い終わったらなるべくはやくNothingを代入してかたづけることでしょう。

Set myCell = Nothing

これに関しては、わざわざNothingを格納する必要はないとおっしゃる方もいます。

 

郵便番号が2段書きになっているかを確認

myLf = InStr(myCell.Value, vbLf)

セル内で改行する場合、Excelの標準機能ではAlt + Enterで改行をしますが、そのときの改行文字はラインフィードvbLfです。

2段書きになっているときは必ず改行文字vbLfがつかわれていますので、その位置をInStr関数で取得します。

もし、2段書きになっているなら、vbLfが何番目の文字かを返します。もし、2段書きになってないなら、0を返します。

 

セル内の文字列の長さによって条件分岐させる

セル内には郵便番号を入力します。123-4567のような形で入力します。

ですので、セル内に1つだけ郵便番号を入力するなら、その文字列の長さは8文字です。

郵便番号を2段書きするなら、その文字列の長さは「郵便番号8文字」+「改行文字1文字」+「郵便番号8文字」の計17文字です。

もしセル内の文字列を削除したなら、文字列の長さは0になります。

文字列の長さがそのほかの数値になる場合は、入力ミスがあったと判断します。

Select Case Len(myCell.Value)
    Case 8
        '住所とフリガナを1段書きで表示する
    Case 17
        If myLf > 0 Then
           '住所とフリガナを2段書きで表示する
        Else
            'エラー対応をする
        End If
    Case 0
        '住所欄とフリガナ欄を空欄にする
    Case Else
        'エラー対応をする
End Select

 

文字列の長さが8文字の場合

If F_CheckUpZip(myCell.Value) = False Then Exit Sub
If F_CheckUpSheet = False Then Exit Sub

Call S_DisplayAddress(myCell.Value)

郵便番号のセルの文字列の長さが8文字の場合は、「123-4567」のようなかたちで郵便番号が入力されているはずです

ここではそれを確認するために、郵便番号かどうかを判定する関数F_CheckUpZipにセルの文字列を引数としてわたして、正当性を確認しています。

 

文字列が郵便番号かどうかを判定するファンクションプロシージャ「F_CheckUpZip」

文字列が郵便番号かどうかを判定するファンクションプロシージャは、8文字の文字列を引数にとり、Boolean型の値を返します。

 

ソースコード(再掲)
Private Function F_CheckUpZip(ByVal myZip As String) _
    As Boolean
    
    F_CheckUpZip = True

    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

まず、プロシージャ名F_CheckUpZipTrueを格納しておきます。

これは感覚的なものかもしれませんが、このファンクションプロシージャでしらべた結果、「ダメ」=文字列が郵便番号でない、とわかったら、TrueではなくFalseを返したい。

しかし、Boolean型のデフォルト値はFalseなので、最初にTrueを入れておくことにしました。

 

For文を使って1文字目から8文字目までを調べる

郵便番号は「123-4567」という形の8文字の文字列で4文字目にハイフン-を含みます。

そこで、4文字目はハイフン-かどうかをしらべ、それ以外のときは半角の数字かどうかをしらべます。

For i = 1 To 8
    Dim myDigit As String: myDigit = Mid(myZip, i, 1)
   'なんらかの処理
Next i

郵便番号の文字列から、Mid関数でi番目の文字列をを取り出して、変数myDigitに格納します。

 

        Select Case i
            Case 4
               '4文字目がハイフンでないときの処理
            Case Else
               '4文字目以外が数字でないときの処理
        End Select

Select文をつかって4文字目とそれ以外で処理を分岐します。

 

If myDigit <> "-" Then
    F_CheckUpZip = False
    Call S_ClearWorksheet
    Exit For
End If

4文字目がハイフン-でないとき、プロシージャ名F_CheckUpZipFalseを格納して、S_ClearWorksheetというサブプロシージャを呼び出して処理をさせ、For文を抜けます。

S_ClearWorksheetというサブプロシージャにはセルの内容をクリアする処理をさせます。何回もくりかえし使う処理なので独立したサブプロシージャにしています。

 

Dim myNumber As Long: myNumber = Asc(myDigit)
If myNumber < 48 Or myNumber > 57 Then
    F_CheckUpZip = False
    Call S_ClearWorksheet
    Exit For
End If

i番目の文字を格納した変数myDigitAsc関数の引数としてつかって、その文字コード (Shift_JIS) を取得し、変数myNumberに格納します。

0から9の数字の文字コード (Shift_JIS) は48から57です。

i番目の文字(4文字目以外)の文字コード (Shift_JIS) が48から57以外のとき、プロシージャ名F_CheckUpZipFalseを格納して、S_ClearWorksheetというサブプロシージャを呼び出して処理をさせ、For文を抜けます。

このように、1文字目から8文字目までをしらべて、条件に該当しないときはプログラムを終了します。

条件にあったときだけ、次の処理を続行します。

実現したいことをいっきにおこなうのではなく、すこしずつ条件をせばめて希望する処理にちかづけるのはよくある処理方法ですね。

 

郵便番号データが入ったシートが存在するかどうかをを判定するファンクションプロシージャ「F_CheckUpSheet」

郵便番号データが入ったシートが存在するかどうかをを判定するファンクションプロシージャは引数をとらず、Boolean型の返り値をかえします。

 

ソースコード(再掲)
Private Function F_CheckUpSheet() As Boolean
    F_CheckUpSheet = True
    
    On Error Resume Next
    
    Dim wsZip As Worksheet
    Set wsZip = Worksheets("zenkoku")
    
    If wsZip Is Nothing Then
        F_CheckUpSheet = False
        MsgBox """zenkoku""シートがありません。", _
            vbExclamation
        Exit Function
        
    End If
    
    On Error GoTo 0
    
    Set wsZip = Nothing
End Function

 

On Error Resume Nextステートメント
On Error Resume Next

On Error Resume Next ステートメントはエラーが発生した行を無視して、次の行の命令文を実行したいときに使います。

ここでは、次の行にエラーが発生したとき、それを無視して、次の行の命令を実行します。

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

Worksheet型の変数wsZipzenkokuシートを格納してます。

ここで、Dim文は変数の宣言だけなのでエラーは発生しませんが、Set文はブック内にzenkokuシートがないとエラーが発生しますね。

エラーが発生すると、wsZipにはなにも格納されず、中身は初期値のNothingのままです。

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

wsZipの中身がNothingのままの場合、プロシージャ名のF_CheckUpSheetFalseを格納して、「"zenkoku"シートがありません。」というメッセージを表示して、プログラムを終了します。

    On Error GoTo 0
    Set wsZip = Nothing

この2つの文は、「おかたづけ」ですね。

On Error GoTo 0は、これを書くと、On Error Resume Nextを無効にして、エラーが発生した場合に特別な処理をせず、ふつうにエラーメッセージを表示します。

On Error GoTo 0On Error Resume Nextとセットだと思っておいたほうがいいですね。

エラー発生時の特別扱いをおわったら、すぐに通常処理にもどすことが大切だと思います。

 

郵便番号を検索して、該当する住所とフリガナを表示するサブプロシージャ「S_DisplayAddress」

このプロシージャがこのプログラムの本題ですね。

でも、実際につかうプログラムでは、ユーザに対する配慮をおこなう「前置き」の部分もかかせません。

このプロシージャでは、入力した郵便番号をzenkokuワークシート 上で探して、その住所とフリガナをセルに表示します。

ワークシート関数ではなく、マクロをつかって処理しているので、セルに入力されるのは数式ではなく、文字列です。

 

ソースコード(再掲)
Private Sub S_DisplayAddress(ByVal myZip As String)
    On Error GoTo HandleError

    Dim wsZip As Worksheet
    Set wsZip = Worksheets("zenkoku")

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

        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 Worksheets("NoticeOfDishonor")
        .Range("O12").Value = wsZip.Cells(myRow, 2).Value
        .Range("P11").Value = wsZip.Cells(myRow, 3).Value
    End With
    
    Set wsZip = Nothing

    Exit Sub
    
HandleError:
    Call S_ClearWorksheet
    
End Sub

 

「On Error GoTo 行ラベル」
Private Sub S_DisplayAddress(ByVal myZip As String)
    On Error GoTo HandleError

    'エラーが発生する可能性がある処理
    
    Exit Sub
    
HandleError:
    Call S_ClearWorksheet
    
End Sub

HandleErrorとは「行ラベル」のことで、エラーが発生したときの移動先です。

On Error Resume Nextはエラーが発生すると、その行を無視して、次の行を実行しますが、On Error GoTo HandleErrorはエラーが発生すると、その行を無視して、HandleErrorに記述している処理を実行します。

On Error GoTo HandleErrorを使ううえで気をつける点は、かならずExit Subを記述することですね。

これがないと、毎回HandleError行ラベルの内容を実行してしまいます。それを避けるために、Exit Subでプロシージャを抜けます。

On Error GoTo 行ラベルは、ただしく使うことがむずかしい文です。多用すると、プログラムが読みにくくなるので、使いすぎないことですね。

ここでは、Worksheet型変数にワークシートを格納したり、Range型変数にセルを格納したり、エラーが発生する可能性が2つ以上あるため、On Error GoTo 行ラベルをつかってます。

 

ワークシート関数「MATCH」をマクロで使って郵便番号を検索する
        Dim myRow As Long
        myRow = .Cells(.Rows.Count, 1).End(xlUp).Row

zenkokuシートには約15万件のデータがありますが、途中に空白のセルはありません。

Rows.Countプロパティでシートの最終行の番号を取得します。

.Cells(.Rows.Count, 1)は、A列の最終行のセルを表します。わたしの環境では、Range("A1048576")を指します。これは、Excelのバージョンによって変わるので注意が必要です。

End(xlUp)プロパティは、今いるセルから上方向に移動します。ちょうどCtrlキーと上方向キーを同時におしたときに移動する場所へと移動します。

.Cells(.Rows.Count, 1).End(xlUp)と書くと、zenkokuシートでRange("A1048576")からRange("A149213")へと移動します。

Rowプロパティは、そのセルの行番号を取得します。.Cells(.Rows.Count, 1).End(xlUp).Row全体では、A列の郵便番号がはいったセルの最終行の行番号149213を返します。

.Cells(.Rows.Count, 1).End(xlUp)はとてもよく使われるので、このまま覚えるといいと思います。

 

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

ここでワークシート関数MATCHを使って、郵便番号を検索しています。Findを使わないのは遅いからです。

excel-ubara.com

この記事にも書いてあるとおり、たしかに遅いです。

ためしにzenkokuシート上でCtrl + Fで検索をおこなってみると、一瞬のタイムラグがあります。

実務上では、このタイムラグがきらわれるので、より高速なを使うことにしました。

WorksheetFunction.Match(検査値,範囲,方法)

検査値は、変数myZipに格納された郵便番号です。

範囲は.Range(.Cells(2, 1), .Cells(myRow, 1))であり、Range("A2")からRange("A149213")のことです。

方法は次のいずれかを指定するのですが、ここでは0を指定して、完全に一致する値をさがします。

数値 内容
-1 「検査値」以上の最小値
0 「検査値」に完全一致する値
1 「検査値」以下の最大値

ワークシート関数MATCHの返り値に関してひとつ大切なことは、あたえられたセル範囲のなかで上から何番目かを返す、ということです。

このプログラムの場合、ほしいのは範囲のなかで何番目かではなく、セルの行番号です。

zenkokuシートは1行目が見出しになっていて、範囲がRange("A2")からRange("A149213")ですから、ワークシート関数MATCHの返り値に1をたすと、セルのただしい行番号を得ることができます。

myRow = myCell.Row

最後に変数myRowを再利用して、得られた答えのセルの行番号を格納します。

 

住所とフリガナをセルに入力
With Worksheets("NoticeOfDishonor")
    .Range("O12").Value = wsZip.Cells(myRow, 2).Value
    .Range("P11").Value = wsZip.Cells(myRow, 3).Value
End With

変数myRowにもとめたい郵便番号のセルの行番号が格納されたので、あとは、住所のセル「O12」とフリガナのセル「P11」に代入するだけです。

代入するのは、=演算子をつかって代入するのがいいでしょう。 VBAでコピペするより代入した方がスピードがあると思います。

 

文字列の長さが17文字の場合

Case 17
    If myLf > 0 Then
       '1段目と2段目の郵便番号の住所とフリガナを格納
    Else
       'エラー処理
    End If

変数myLfの値が0より大きいということは改行文字が郵便番号のセルにふくまれるということです。改行文字がある場合は、1段目の郵便番号と2段目の郵便番号を順番にさがして、住所のセルとフリガナのセルにそれぞれ2段書きで格納します。

 

1段目と2段目の郵便番号の住所とフリガナを格納
my1stValue = Left(myCell.Value, myLf - 1)
my2ndValue = Mid(myCell.Value, myLf + 1)

If F_CheckUpZip(my1stValue) = False Then Exit Sub
If F_CheckUpZip(my2ndValue) = False Then Exit Sub
If F_CheckUpSheet = False Then Exit Sub

Call S_DisplayAddress2(my1stValue, my2ndValue)

my1stValueは1段目の郵便番号、改行文字よりも前の7文字、my2ndValueは2段目の郵便番号、改行文字よりも後の7文字です。

どちらの文字列もF_CheckUpZipで調べて、郵便番号の形(123-4567)になっていなかったら、プログラムを終了します。

そして、F_CheckUpSheetで調べて、zenkokuシートがなかったときもプログラムを終了します。

 

2つの郵便番号を検索して、該当する住所とフリガナを表示するサブプロシージャ「S_DisplayAddress2」

引数が2つにふえただけで、基本的な処理は、郵便番号が1つの場合のS_DisplayAddressサブプロシージャとかわりません。

 

ソースコード(再掲)
Private Sub S_DisplayAddress2( _
    ByVal my1stValue As String, ByVal my2ndValue As String)
    
    On Error GoTo HandleError

    Dim wsZip As Worksheet
    Set wsZip = Worksheets("zenkoku")

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

        Dim myRange1 As Range, myRange2 As Range
        Set myRange1 = _
            .Cells(WorksheetFunction.Match(my1stValue, _
            .Range(.Cells(2, 1), .Cells(myRow, 1)), 0) _
            + 1, 1)
        Set myRange2 = _
            .Cells(WorksheetFunction.Match(my2ndValue, _
            .Range(.Cells(2, 1), .Cells(myRow, 1)), 0) _
            + 1, 1)
        
        Dim myRow1 As Long, myRow2 As Long
        myRow1 = myRange1.Row
        myRow2 = myRange2.Row
        
    End With

    Set myRange1 = Nothing: Set myRange2 = Nothing
    
    With Worksheets("NoticeOfDishonor")
        .Range("O12").Value = _
            wsZip.Cells(myRow1, 2).Value & vbLf & _
            wsZip.Cells(myRow2, 2).Value
        .Range("P11").Value = _
            wsZip.Cells(myRow1, 3).Value & vbLf & _
            wsZip.Cells(myRow2, 3).Value
                              
    End With

    Set wsZip = Nothing

    Exit Sub
    
HandleError:
    Call S_ClearWorksheet
    
End Sub

サブプロシージャ「S_DisplayAddress」と本質的におなじことをしているので、説明は割愛します。

 

文字列の長さが0文字の場合

文字列の長さが0文字ということは、何も入っていないということです。DELETEキーでセルの内容を削除した場合などがそれにあたります。

Case 0
    Range("O12, P11").Value = ""
    myCell.Activate

郵便番号のセルだけでなく、住所とフリガナのセルも内容を削除します。

 

文字列の長さがその他の場合

文字列の長さが8文字(郵便番号1つ)、17文字(郵便番号2つ)、0文字(セルに何も文字列がはいっていない)の場合以外は、メッセージを表示して、プログラムを終了します。ここにメッセージを直接書いてもかまいませんが、プログラムの見通しをよくするために独立したプロシージャを書いています。

Case Else
    Call S_ClearWorksheet

 

セルの内容をクリアするサブプロシージャ「S_ClearWorksheet」

エラーメッセージを表示して、郵便番号のセル・住所のセル・フリガナのセルの文字列をクリアするサブプロシージャです。

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

 

ThisWorkbookモジュールの「Workbook_Open」プロシージャ

このブックをひらいたときにNoticeOfDishonorシートを選択して、セル「AG3」を選択するマクロです。

こうしておけば、入力担当者がいちいち郵便番号のセルを探す手間がはぶけます。

Private Sub Workbook_Open()
    Worksheets("NoticeOfDishonor").Activate
    Range("AG3").Activate
End Sub

 

標準モジュールのデータ更新マクロ

住所.jp」さんからダウンロードしたCSVファイルはそのままではわたしの希望のかたちにはなっていません。そこでダウンロードしたCSVファイルに対してプログラムを実行して、セルの内容を希望のかたちに変更します。

ソースコード

Option Explicit

'http://jusyo.jp/downloads/new/csv/csv_zenkoku.zip

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
    
    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:="01", _
                     Replacement:="1", LookAt:=xlPart
            .Replace What:="02", _
                     Replacement:="2", LookAt:=xlPart
            .Replace What:="03", _
                Replacement:="3", LookAt:=xlPart
            .Replace What:="04", _
                Replacement:="4", LookAt:=xlPart
            .Replace What:="05", _
                Replacement:="5", LookAt:=xlPart
            .Replace What:="06", _
                Replacement:="6", LookAt:=xlPart
            .Replace What:="07", _
                Replacement:="7", LookAt:=xlPart
            .Replace What:="08", _
                Replacement:="8", LookAt:=xlPart
            .Replace What:="09", _
                Replacement:="9", 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

ソースコードの解説

 

データ更新マクロの流れを確認

  • プロパティ・プロシージャSwitchでマクロの高速化・自動化の設定をして
  • ファンクション・プロシージャF_CheckUpFileでCSVファイルが存在しているか、開いているかいないかをチェックして
  • ファンクション・プロシージャF_CheckUpSheetzenkokuシートの有無を確認して
  • サブプロシージャS_CreateZIPToAddressTable_Coreでセルの内容を変更します。

 

プロパティ・プロシージャ「Switch」

Property Letプロシージャは、プロパティの値を設定するプロシージャです。ここでは、プロシージャの高速化・自動化に関するプロパティをまとめて設定するためにつかってます。

高速化・自動化の「切り替え」をするという意味でSwitchという名前にしています。

ほかの言語では、VBAのSelect文と同じ意味で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

画面再描画・イベント発生・警告自動表示・ブック自動計算・プリンタ通信を最適化します。

t-homさんのサイトにくわしい説明があります。

thom.hateblo.jp

 

CSVファイルの状態を確認する「F_CheckUpFile」ファンクション・プロシージャ

まず、Dir関数でCSVファイルが存在するかどうかを確認して、存在しなければ、プロシージャ名の変数F_CheckUpFile0を格納します。

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

 

ファイルが存在するとわかったら、開いているすべてのファイルを確認して、CSVファイルの名前があったら、プロシージャ名の変数F_CheckUpFile1を格納し、なかったら、2を格納します。

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

ここは改善の余地があるかもしれません。For Each文で全部のブックをしらべるのではなく、Set文でmyFileにCSVを格納してみて、エラーが発生するかどうかをしらべたり、プロシージャのデータ型をLongではなく、String型にして、返り値をNoExistenceOpenedNoOpenedなどの自分にとってわかりやすい文字列を返り値に設定するのもいいかもしれません。

 

CSVファイルのシート名を確認する「F_CheckUpSheet」

シート名をすべてしらべて、zenkokuになっていれば、処理を続行。

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

 

zenkokuになっていなければ、メッセージをだして、シート名を変更するよう促して、プログラムを終了します。

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

 

実際にセル内のデータを操作する「S_CreateZIPToAddressTable_Core」サブプロシージャ

CSVファイルのデータは、いろいろな人のニーズを考えて、分割して掲載されているので、「郵便番号」「住所(漢字)」「住所(カナ)」の3つに集約します。

必要としていない列を削除

分割してあるデータの中で、結合したいデータではない列を削除します。

このとき、いちばん右の列から削除すると、自分で混乱することがありません。左の列から削除すると、その都度、列番号が変わるので、やめたほうがいいですね。

With myWB.Worksheets("zenkoku")
    .Columns(22).Delete
    .Columns(18).Delete
    .Range(.Columns(14), .Columns(15)).Delete
    .Range(.Columns(1), .Columns(4)).Delete
End With

 

住所(漢字)と住所(カナ)のデータを結合

データの中に事業所フラグ(01)があって、事業所の住所データと事業所以外の住所データではデータの構造がちがうので、結合のしかたもちがいます。

ですので、IFで分岐させることにして、漢字のデータとカナのデータのそれぞれのための結合用関数を用意します。

そして、一番上のデータのセルにワークシート関数を埋め込みます。

With myWB.Worksheets("zenkoku")
    .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,""""))"
End With

ワークシート関数を埋め込むのは、VBAでFor文を回して処理すると非常に遅くて、いったんワークシート関数を埋め込んで、その数式をコピーしてExcelに計算させたほうが圧倒的に速いからです。

 

挿入した数式をコピー

Copyメソッドで数式をコピーするのですが、注意点がひとつ。

Switchプロパティ・プロシージャのなかで自動計算をオフにしているので、数式をコピーしたあと、いったん自動計算をオンにします。

すると、自動計算がはじまり、それぞれの行の住所のデータを結合してくれます。

自動計算をオンにしたらすぐに計算(結合)してくれるので、次の命令文で自動計算をすぐにオフにしてかまいません。

With myWB.Worksheets("zenkoku")
    .Range(.Cells(2, 15), .Cells(2, 16)).Copy _
        Destination:=.Range( _
        .Cells(3, 15), .Cells(myRow, 16))
        
    With Application
        .Calculation = xlCalculationAutomatic
        .Calculation = xlCalculationManual
    End With
End With

 

数式を文字列に変換

これもExcelの機能で処理するのがいいでしょう。

というか、ほかに処理方法はあるのでしょうか。

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

 

余分なデータを削除

挿入した数式を文字列に変換したことで、数式の元データとなっていた列を削除することが可能になりました。

With myWB.Worksheets("zenkoku")
    .Range(.Columns(2), .Columns(14)).Delete
End With

 

さらなるデータの整形

住所(漢字)データのセルと住所(カナ)データのセルの横幅をひろげて見やすくします。

S_ReplaceZeroToNothingサブプロシージャで、「01」〜「09」という丁目の表記を「1」〜「9」に変更します。実際の書類上では「01丁目」という表記は変なので「1丁目」にします。

S_FreezePanesサブプロシージャで、ウィンドウ枠を固定して、常に見出しが見えるようにしておきます。

    With myWB.Worksheets("zenkoku")
        .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)

 

CSVファイルのシートをコピー

S_CopyTableサブルーチンを呼んで、CSVファイルの整形済みのzenkokuシートをブックにコピーします。

Call S_CopyTable(myWB)

 

「01」を「1」に置換する「S_ReplaceZeroToNothing」サブプロシージャ

Excelの標準機能の「置換」機能をVBAから利用して「01丁目」を「1丁目」にします。

これも、標準機能をつかわずに、For文で回したりすると、おそろしく時間がかかります。

        With .Range(.Cells(2, 3), .Cells(myRow, 3))
            .Replace What:="01", _
                Replacement:="1", LookAt:=xlPart
            .Replace What:="02", _
                Replacement:="2", LookAt:=xlPart
            .Replace What:="03", _
                Replacement:="3", LookAt:=xlPart
            .Replace What:="04", _
                Replacement:="4", LookAt:=xlPart
            .Replace What:="05", _
                Replacement:="5", LookAt:=xlPart
            .Replace What:="06", _
                Replacement:="6", LookAt:=xlPart
            .Replace What:="07", _
                Replacement:="7", LookAt:=xlPart
            .Replace What:="08", _
                Replacement:="8", LookAt:=xlPart
            .Replace What:="09", _
                Replacement:="9", LookAt:=xlPart
        End With

 

ウィンドウ枠を固定する「S_FreezePanes」サブプロシージャ

FreezePanesプロパティは、Windowオブジェクトに対しておこなうものですが、ActiveWindowに対しておこなうのが安全です。

そのため、まず、ブックをアクティブにして、シートをアクティブにして、セルを選択してから、FreezePanesプロパティにTrueを設定します。

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

 

CSVファイルのシートをコピーする「S_CopyTable」サブプロシージャ

まず、ブックの中にzenkokuシートがあったら、それは古いデータなので、削除します。

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

 

準備がととのったら、zenkokuシートをCSVファイルからブックにコピーして、CSVファイルをとじます。

最後にブックを保存して終了です。

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

ThisWorkbook.Save

 

おわりに

最後まで読んでいただき、ありがとうございました。

長いかなあとも思いますが、せっかく書いたので、このままアップします。

 

Copyright 2018 m-eye blog All Rights Reserved.