Input Support System of Notice of Dishonor – Move the Active Cell to Specified Cell Only By Enter Key
はじめに
不渡届を題材に、帳票の入力支援システムを考えてみました。
パソコンにあまり慣れていない方に、少しでもラクに入力作業をおこなっていただくために、特定の文字列を自動的に挿入したり、データをリストから選択したり、Enterキーで入力するセルだけを移動したりします。
・動作は無保証です。
・動作確認はExcel 2016 + Windows 10でおこなっています。
・Excel 2013でもおそらく動作すると思います。
・ただし、ワークシート関数であるUnicode関数を使用しているので、Excel 2010では動作しません。
・Excel 2010で同様のシステムを構築するには、Unicode関数の代わりにCODE関数を、Unichar関数の代わりにCHAR関数を、WorksheetFunctionオブジェクトの代わりにEvaluate関数を使用してください。
・また、「ひらがな・カタカナ相互変換プログラム – Evaluateメソッドの使い方」も参考にしてみてください。
・今回のファイルは「不渡届」の帳票ファイルと「郵便番号・住所リスト」のデータファイルの2つになっていますので、ZIP圧縮して、1つのファイルにしております。
・ファイルの分割については、「郵便番号を住所に変換するプログラム – プログラムとデータを分けるメリット」も参考にしてみてください。
・ファイルはここからダウンロードしてください。
不渡届を入力用帳票にすること
みなさんは手形や小切手の「不渡り」をご存知でしょうか。概要はウィキペディアでもご覧いただくとして、「不渡り」が出ると「不渡届」を手形交換所提出しなければなりません。
実物は、一般財団法人静岡県銀行協会のこのPDF文書で見ることができます。
それを参考に、いわゆるエクセル方眼紙風（ネ申エクセルではありません）のデータ入力用帳票として「不渡届」を作成しました。
もちろんその先には、アクセスとの連携を視野に入れて、データベースに「不渡届」の内容を蓄積したいということを考えています。
今まで手書きで不渡届を書いていたパソコンが不得手な方にすこしでもラクに入力してもらうために、Excelの書式設定・条件付書式・関数・VBAを駆使して入力用帳票を作成したのですが、今まで考えてきた単機能のファイルとは違って、様々なテクニックを集めて作りました。
ファイルの構成
不渡届を入力用帳票化したファイルと、郵便番号・住所を入力する必要があるので、その郵便番号・住所データファイルに分かれています。
入力用帳票ファイルNoticeOfDishonor.xlsmでは、標準モジュールのModule1モジュールに「特定のセルのみを移動するマクロ」を記載し、シートモジュールのSheet1モジュールに「セルの値が変化すると特定の値を付加するマクロ」や「書式を設定するマクロ」や「カタカナをひらがなに変換するマクロ」や「郵便番号から住所を自動入力するマクロ」を記載し、ブックモジュールであるThisWorkbookモジュールに「自動で郵便番号・住所データファイルを開くマクロ」や「自動で郵便番号・住所データファイルを閉じるマクロ」を記載しています。
郵便番号・住所データファイルzenkoku.xlsmでは、標準モジュールのModule1モジュールに「データ更新マクロ」を記載しています。
「Module1」標準モジュールのソースコード
今回は、読む方のわかりやすさのために、Cellsプロパティではなく、Rangeプロパティを使って、プログラムを書いてみました。
Option Explicit
Sub S_IndicateEnterDirection()
Select Case ActiveCell.Address(False, False)
Case "AG3"
Range("G8").Activate
Case "G8"
Range("J8").Activate
Case "J8"
Range("Y8").Activate
Case "Y8"
Range("J7").Activate
Case "J7"
Range("B8").Activate
Case "B8"
Range("AD9").Activate
Case "AD9"
Range("AD10").Activate
Case "AD10"
Range("G10").Activate
Case "G10"
Range("N10").Activate
Case "N10"
Range("I13").Activate
Case "I13"
Range("O12").Activate
Case "O12"
Range("P11").Activate
Case "P11"
Range("D16").Activate
Case "D16"
Range("Q16").Activate
Case "Q16"
Range("S16").Activate
Case "S16"
Range("W16").Activate
Case "W16"
Range("AE15").Activate
Case "AE15"
Range("D19").Activate
Case "D19"
Range("O19").Activate
Case "O19"
Range("AG3").Activate
Case Else
On Error Resume Next
Select Case Application.MoveAfterReturnDirection
Case xlDown
ActiveCell.Offset(1, 0).Activate
Case xlToRight
ActiveCell.Offset(0, 1).Activate
Case xlUp
ActiveCell.Offset(-1, 0).Activate
Case xlToLeft
ActiveCell.Offset(0, -1).Activate
End Select
End Select
End Sub
Sub S_AddKeysToMacro()
Application.OnKey "~", "S_IndicateEnterDirection"
Application.OnKey "{Enter}", "S_IndicateEnterDirection"
End Sub
Sub S_RemoveKeysFromMacro()
Application.OnKey "~"
Application.OnKey "{Enter}"
End Sub
「Module1」標準モジュールのソースコードの解説
S_IndicateEnterDirectionサブプロシージャは、特定のセルから指定したセルに移動するための順序を指定するプロシージャです。
Addressプロパティを使用して、ActiveCell.Address(False, False)で特定のセルのアドレスを取得し、そのアドレスが"AG3"ならば、指定したセルRange("G8")に移動します。
セルの移動は、Select Case ～ End Selectを使用して、循環するようにします。
循環の順序は次のとおりです。
AG3 （店舗コード欄） ↓ G8 （前株欄） ↓ J8 （法人名又は個人名欄） ↓ Y8 （後株欄） ↓ J7 （フリガナ欄） ↓ B8 （索引（かしら字）欄） ↓ AD9 （手形・小切手の種類欄） ↓ AD10 （金額欄） ↓ G10 （代表者の肩書欄） ↓ N10 （代表者名又は屋号欄） ↓ I13 （郵便番号欄） ↓ O12 （住所（漢字）欄） ↓ P11 （住所（フリガナ）欄） ↓ D16 （職業欄） ↓ Q16 （生年月日（元号）欄） ↓ S16 （生年月日（年月日）欄） ↓ W16 （資本金（千円単位）欄） ↓ AE15 （不渡事由欄） ↓ D19 （持出銀行欄） ↓ O19 （持出支店欄） ↓ AG3 （店舗コード欄）
その他のセルの場合は、Excelのオプションで指定する「Enterキーを押したら、セルを移動する」方向に従います。
それは、Application.MoveAfterReturnDirectionで移動方向を取得します。
xlDownの場合は下のセルに、xlToRightの場合は右のセルに、xlUpの場合は上のセルに、xlToLeftの場合は左のセルに移動します。
S_AddKeysToMacroサブプロシージャは、S_IndicateEnterDirectionサブプロシージャの起動キーをEnterに設定します。
Application.OnKey "~", "S_IndicateEnterDirection"はメインキーボードのEnterキーにS_IndicateEnterDirectionサブプロシージャを関連付けます。
Application.OnKey "{Enter}", "S_IndicateEnterDirection"はテンキーのEnterキーにS_IndicateEnterDirectionサブプロシージャを関連付けます。
通常、Enterキーというと引数Keyは"{Enter}"と思いがちですが、これは「テンキー」の方のEnterです。メインキーボードのほうのEnterの引数Keyは"~"です。
マクロにショートカットキーを設定する方法はいくつかありますが、本プログラムのような場合、Application.OnKeyでこの入力支援システムのファイルを起動したときに、同時にマクロにショートカットキーを設定し、ファイルの終了時にショートカットキーを解除するのがいいと思います。
というわけで、S_RemoveKeysFromMacroサブプロシージャは、メインキーボードのEnterとテンキーのEnterのマクロショートカットキーを解除します。
Application.OnKeyの書式はApplication.OnKey "Key" , Procedureですが、 , Procedureを省略すると、ショートカットキーを解除することができます。
「ThisWorkbook」ブックモジュールのソースコード
Option Explicit
Private Sub Workbook_Open()
If F_CheckUpFile = False Then
Workbooks.Open Filename:="zenkoku.xlsm", ReadOnly:=True
ActiveWindow.Visible = False
End If
Worksheets("NoticeOfDishonor").Activate
Range("AG3").Activate
Call S_AddKeysToMacro
End Sub
Private Function F_CheckUpFile() As Boolean
Dim myPath As String
myPath = ThisWorkbook.Path & "\zenkoku.xlsm"
If Dir(myPath) = "" Then
MsgBox "郵便番号・住所データファイルが" & _
"同じフォルダに存在しません。", vbExclamation
F_CheckUpFile = True
Exit Function
End If
Dim myFile As Workbook
For Each myFile In Workbooks
With myFile
If .Name = "zenokoku.xlsm" Then
If .ReadOnly = False Then
.Activate
.Save
.ChangeFileAccess xlReadOnly
ActiveWindow.Visible = False
End If
F_CheckUpFile = True
Exit Function
End If
End With
Next myFile
End Function
Private Sub Workbook_BeforeClose(Cancel As Boolean)
Call S_RemoveKeysFromMacro
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
If Workbooks.Count = 1 Then
Application.Quit
End If
End Sub
「ThisWorkbook」ブックモジュールのソースコードの解説
「Workbook_Open」サブプロシージャの解説
この入力支援システムのファイルを開いたときに、zenkoku.xlsmを同時に開きます。
F_CheckUpFileファンクションプロシージャでzenkoku.xlsmの存在・状態をチェックして、Workbooks.Open Filename:="zenkoku.xlsm", ReadOnly:=Trueで読み取り専用で開き、ActiveWindow.Visible = Falseで非表示にします。
Worksheets("NoticeOfDishonor").Activateでこの入力支援システムのファイルをアクティブにし、Range("AG3").Activateでセル「AG3」を選択します（これは入力担当者のためです）。
最後にCall S_AddKeysToMacroで、Enterで特定のセルに移動するマクロにショートカットキーを設定します。
「F_CheckUpFile」ファンクションプロシージャの解説
myPath = ThisWorkbook.Path & "\zenkoku.xlsm"でこの入力支援システムのファイルのパスと、郵便番号・住所データファイル名を変数myPathに代入します。
この入力支援システムのファイルのパスはC:\Users\amacoda\Documents\Excel ファイルとなっており、パスの途中に空白文字が入っています。
ですので、この空白のせいでIf Dir(ThisWorkbook.Path & "\zenkoku.xlsm") = "" ThenとDIR関数の引数に直接ファイルパスを代入すると、エラーが発生します。
このエラーを回避するために、ファイルパスをいったん変数に代入して、If Dir(myPath) = "" Thenとすると、エラーは発生しません。
このセンテンスを実行して、zenkoku.xlsmが存在していなければ、変数F_CheckUpFileにTrueを代入して、Workbook_Openサブプロシージャを終了します。
zenkoku.xlsmが存在していれば、現在開いているブックの中にzenkoku.xlsmがあるかどうか、読み書き自由で開いているかどうかを調べ、もしそうなら一旦保存し、.ChangeFileAccess xlReadOnlyで読み取り専用で開きなおし、ActiveWindow.Visible = Falseでウィンドウを非表示にし、F_CheckUpFileにTrueを代入して、終了します。
「Workbook_BeforeClose」サブプロシージャの解説
まずCall S_RemoveKeysFromMacroでマクロのショートカットキーを解除し、Application.DisplayAlerts = Falseを設定して、zenkoku.xlsmが開いていたら閉じます。
If Workbooks.Count = 1 Thenで残りの開いているブックがこの入力支援システムのみかどうかを確認し、もしそうならApplication.QuitでExcelアプリケーションの終了を予約します。
このプロシージャ自体がこの入力支援システムのファイルを閉じる前に実行されるので、このプロシージャを実行すると、ファイルが閉じられます。その後、予約しておいたExcelアプリケーションの終了が実行されます。
「Sheet1」シートモジュールのソースコード
Option Explicit
Private Sub Worksheet_Activate()
Range("AG3").Activate
End Sub
Private Sub Worksheet_Change(ByVal Target As Range)
Select Case True
Dim myCell As Range
Dim myLf As Long
Dim my1stValue As String, my2ndValue As String
Case Not Intersect(Target, Range("J8")) Is Nothing
Set myCell = Range("J8")
myLf = InStr(myCell.Value, vbLf)
If (Left(myCell.Value, 5) <> "（登記上）") And (myLf > 0) Then
my1stValue = "（登記上）" & Left(myCell.Value, myLf - 1)
my2ndValue = "（券面）" & Mid(myCell.Value, myLf + 1)
myCell.Value = my1stValue & vbLf & my2ndValue
End If
Set myCell = Nothing
Case Not Intersect(Target, Range("J7")) Is Nothing
Set myCell = Range("J7")
myLf = InStr(myCell.Value, vbLf)
If (Left(myCell.Value, 5) <> "（登記上）") And (myLf > 0) Then
my1stValue = "（登記上）" & Left(myCell.Value, myLf - 1)
my2ndValue = "（券面）" & Mid(myCell.Value, myLf + 1)
myCell.Value = my1stValue & vbLf & my2ndValue
Range("J7").Font.Size = 10
Else
Range("J7").Font.Size = 12
Range("B8").Value = ""
End If
If Len(myCell.Value) > 0 Then
Dim myString As String
If Left(myCell.Value, 5) = "（登記上）" Then
myString = Mid(myCell.Value, 6, 1)
Else
myString = Left(myCell.Value, 1)
End If
Dim myCode As Long
myCode = WorksheetFunction.Unicode(myString)
Call S_KanaConverter(myCode, Range("J7"), Range("B8"))
End If
Set myCell = Nothing
Case Not Intersect(Target, Range("N10")) Is Nothing
Set myCell = Range("N10")
myLf = InStr(myCell.Value, vbLf)
If (Left(myCell.Value, 5) <> "（登記上）") And (myLf > 0) Then
my1stValue = "（登記上）" & Left(myCell.Value, myLf - 1)
my2ndValue = "（券面）" & Mid(myCell.Value, myLf + 1)
myCell.Value = my1stValue & vbLf & my2ndValue
End If
Set myCell = Nothing
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_CheckUpBook = 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_CheckUpBook = 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").Activate
Case Else
Call S_ClearWorksheet
End Select
Set myCell = Nothing
Case Not Intersect(Target, Range("O12")) Is Nothing
Set myCell = Range("O12")
myLf = InStr(myCell.Value, vbLf)
If (Left(myCell.Value, 5) <> "（登記上）") And (myLf > 0) Then
my1stValue = "（登記上）" & Left(myCell.Value, myLf - 1)
my2ndValue = "（券面）" & Mid(myCell.Value, myLf + 1)
myCell.Value = my1stValue & vbLf & my2ndValue
End If
Set myCell = Nothing
Case Not Intersect(Target, Range("P11")) Is Nothing
Set myCell = Range("P11")
myLf = InStr(myCell.Value, vbLf)
If (Left(myCell.Value, 5) <> "（登記上）") And (myLf > 0) Then
my1stValue = "（登記上）" & Left(myCell.Value, myLf - 1)
my2ndValue = "（券面）" & Mid(myCell.Value, myLf + 1)
myCell.Value = my1stValue & vbLf & my2ndValue
End If
Set myCell = Nothing
Case Not Intersect(Target, Range("D19")) Is Nothing
Set myCell = Range("D19")
myLf = InStr(myCell.Value, vbLf)
If (InStr(myCell.Value, "（") = 0) And (myLf > 0) Then
my1stValue = Left(myCell.Value, myLf - 1)
my2ndValue = "（" & Mid(myCell.Value, myLf + 1)
myCell.Value = my1stValue & vbLf & my2ndValue
End If
Set myCell = Nothing
Case Not Intersect(Target, Range("O19")) Is Nothing
Set myCell = Range("O19")
myLf = InStr(myCell.Value, vbLf)
If (InStr(myCell.Value, "）") = 0) And (myLf > 0) Then
my1stValue = Left(myCell.Value, myLf - 1)
my2ndValue = Mid(myCell.Value, myLf + 1) & "）"
myCell.Value = my1stValue & vbLf & my2ndValue
End If
Set myCell = Nothing
End Select
End Sub
Private Sub S_KanaConverter(ByVal myCode As Long, _
ByVal Katakana As Range, ByVal Hiragana As Range)
If (myCode < 12449) Or (myCode > 12532) Then
MsgBox "カタカナを入力してください。", vbExclamation
Katakana.Value = "": Hiragana.Value = "": Katakana.Activate
Else
Select Case myCode
Case 12449 To 12458
Call S_NormalConverter(myCode, Hiragana)
Case 12459 To 12482
Call S_ModTwo_1(myCode, Hiragana)
Case 12483 To 12489
Call S_ModTwo_2(myCode, Hiragana)
Case 12490 To 12494
Call S_NormalConverter(myCode, Hiragana)
Case 12495 To 12509
Call S_ModThree(myCode, Hiragana)
Case 12510 To 12531
Call S_NormalConverter(myCode, Hiragana)
Case 12532
Call S_VConverter(Hiragana)
End Select
End If
End Sub
Private Sub S_NormalConverter(ByVal myCode As Long, _
ByVal Hiragana As Range)
Hiragana.Value = WorksheetFunction.Unichar(myCode - 96)
End Sub
Private Sub S_ModTwo_1(ByVal myCode As Long, _
ByVal Hiragana As Range)
Select Case myCode Mod 2
Case 1
Call S_NormalConverter(myCode, Hiragana)
Case 0
myCode = myCode - 1
Call S_NormalConverter(myCode, Hiragana)
End Select
End Sub
Private Sub S_ModTwo_2(ByVal myCode As Long, _
ByVal Hiragana As Range)
Select Case myCode Mod 2
Case 0
Call S_NormalConverter(myCode, Hiragana)
Case 1
myCode = myCode - 1
Call S_NormalConverter(myCode, Hiragana)
End Select
End Sub
Private Sub S_ModThree(ByVal myCode As Long, _
ByVal Hiragana As Range)
Select Case myCode Mod 3
Case 0
Call S_NormalConverter(myCode, Hiragana)
Case 1
myCode = myCode - 1
Call S_NormalConverter(myCode, Hiragana)
Case 2
myCode = myCode - 2
Call S_NormalConverter(myCode, Hiragana)
End Select
End Sub
Private Sub S_VConverter(ByVal Hiragana As Range)
Hiragana.Value = "う"
End Sub
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
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(ByVal myZip As String)
On Error GoTo HandleError
Dim wbZip As Workbook
Set wbZip = Workbooks("zenkoku.xlsm")
Dim wsZip As Worksheet
Set wsZip = wbZip.Worksheets("zenkoku")
Dim wsDishonor As Worksheet
Set wsDishonor = Worksheets("NoticeOfDishonor")
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 wsDishonor
.Range("O12").Value = wsZip.Cells(myRow, 2).Value
.Range("P11").Value = wsZip.Cells(myRow, 3).Value
End With
Set wsDishonor = Nothing: Set wsZip = Nothing: Set wbZip = Nothing
Exit Sub
HandleError:
Call S_ClearWorksheet
End Sub
Private Sub S_DisplayAddress2( _
ByVal my1stValue As String, ByVal my2ndValue As String)
On Error GoTo HandleError
Dim wbZip As Workbook
Set wbZip = Workbooks("zenkoku.xlsm")
Dim wsZip As Worksheet
Set wsZip = wbZip.Worksheets("zenkoku")
Dim wsDishonor As Worksheet
Set wsDishonor = Worksheets("NoticeOfDishonor")
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 wsDishonor
.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 wsDishonor = Nothing: Set wsZip = Nothing: Set wbZip = Nothing
Exit Sub
HandleError:
Call S_ClearWorksheet
End Sub
Private Sub S_ClearWorksheet()
MsgBox "郵便番号が正しくありません。" & vbCrLf & _
"正しい形式「123-4567」（ハイフンあり）で" & vbCrLf & _
"入力してください。", vbExclamation
Range("I13, O12, P11").Value = ""
Range("I13").Activate
End Sub
「Sheet1」シートモジュールのソースコードの解説
「Worksheet_Activate」サブプロシージャの解説
Range("AG3").Activateで、シートを開いたときにセル「AG3」を常に選択するようにします。
「Worksheet_Change」サブプロシージャの解説
この入力支援システムの中で一番長いプロシージャになっています。
ある程度のプロシージャの分割はおこなっていますが、必要以上の分割はおこなっていません。
興味のある方は、ご自分でプロシージャの分割をお試しください。
全体の構成としては、次のようになります。
Private Sub Worksheet_Change(ByVal Target As Range)
Select Case True
Dim myCell As Range
Dim myLf As Long
Dim my1stValue As String, my2ndValue As String
Case Not Intersect(Target, Range("J8")) Is Nothing
～～～～～～～～～～～
Case Not Intersect(Target, Range("J7")) Is Nothing
～～～～～～～～～～～
Case Not Intersect(Target, Range("N10")) Is Nothing
～～～～～～～～～～～
Case Not Intersect(Target, Range("I13")) Is Nothing
～～～～～～～～～～～
Case Not Intersect(Target, Range("O12")) Is Nothing
～～～～～～～～～～～
Case Not Intersect(Target, Range("P11")) Is Nothing
～～～～～～～～～～～
Case Not Intersect(Target, Range("D19")) Is Nothing
～～～～～～～～～～～
Case Not Intersect(Target, Range("O19")) Is Nothing
～～～～～～～～～～～
End Select
End Sub
上記の例に掲げられたセルは、それぞれ入力支援をおこなうべきセルであり、セルの値に変化があった場合におこなう入力支援作業を記述します。
上記のセルにおこなう入力支援作業は次のとおりです。
Range("J8") （法人名又は個人名欄） 二段書きの場合文字列自動挿入
Range("J7") （フリガナ欄） 二段書きの場合文字列自動挿入
フリガナからかしら字自動挿入
Range("N10") （代表者名又は屋号欄） 二段書きの場合文字列自動挿入
Range("I13") （郵便番号欄） 郵便番号から住所を自動挿入
Range("O12") （住所（漢字）欄） 二段書きの場合文字列自動挿入
Range("P11") （住所（フリガナ）欄） 二段書きの場合文字列自動挿入
Range("D19") （持出銀行名欄） 二段書きの場合文字列自動挿入
Range("O19") （持出支店名欄） 二段書きの場合文字列自動挿入
以下、上記のセルごとに見ていきます。
「Case Not Intersect(Target, Range(“J8”)) Is Nothing」の場合
ここでは「二段書きの場合文字列自動挿入」の基本的パターンをお示しします。
Set myCell = Range("J8")で変数myCellにセルを代入し、プロパティ・メソッドを使えるようにします。
myLf = InStr(myCell.Value, vbLf)でラインフィード（vbLf）＝改行文字の位置を取得します。
挿入する文字列は一段目の先頭に（登記上）、二段目の先頭に（券面）です。
If (Left(myCell.Value, 5) <> "（登記上）") And (myLf > 0) Thenで、一段目の先頭に（登記上）という文字列が入っていないか、改行文字が存在するかどうかを確認します。
最初に（登記上）という文字列が入っていないか確認しないと、無限ループになってしまいますので、必ず確認します。
次に改行文字があるかどうかを確認し、ある場合のみ、文字列を挿入します。
my1stValue = "（登記上）" & Left(myCell.Value, myLf - 1)で、一段目の文字列を変数my1stValueに代入し、my2ndValue = "（券面）" & Mid(myCell.Value, myLf + 1)で、二段目の文字列を変数my2ndValueに代入します。
myCell.Value = my1stValue & vbLf & my2ndValueで、一段目の文字列my1stValueと改行文字vbLfと二段目の文字列my2ndValueを結合し、変数myCellであるセル「J8」の値として、二段書きの文字列を代入します。
最後にSet myCell = Nothing変数myCellにNothingを代入します。
「Case Not Intersect(Target, Range(“J7”)) Is Nothing」の場合
セル「J7」では、「二段書きの場合文字列自動挿入」の基本パターンと同時に「フォントサイズの変更」と「セル『B8』の内容消去」、そして「セル『B8』へのかしら字の自動挿入」をおこないます。
「二段書きの場合文字列自動挿入」の基本パターンの場合、Set myCell = Range("J7")と該当のセルがセル「J7」であることを除いて、セル「J8」と一緒です。
「フォントサイズの変更」の場合、
If (Left(myCell.Value, 5) <> "（登記上）") And (myLf > 0) Then
～～～～～～～～～～～
Range("J7").Font.Size = 10
Else
Range("J7").Font.Size = 12
Range("B8").Value = ""
End If
このソースから、「二段書きの場合文字列自動挿入」の基本パターンのときはフォントサイズを「10」に変更して文字の大きさを小さくして、そうでないときはセル「J7」のフォントの大きさを「12」にして、セル「B8」の値を「長さ0の文字列『””』」にします。
そして、If Len(myCell.Value) > 0 Thenでセル「J7」の値が空白でないとき、If Left(myCell.Value, 5) = "（登記上）" Thenでセル「J7」の最初の5文字が「（登記上）」である場合はセル「J7]の最初の6文字目をmyString = Mid(myCell.Value, 6, 1)で変数myStringに代入し、そうでない場合はセル「J7」の最初の1文字目をmyString = Left(myCell.Value, 1)で変数myStringに代入します。
次に、myCode = WorksheetFunction.Unicode(myString)でUnicode関数を使って、ユニコード文字番号を取得します。
さらに、Call S_KanaConverter(myCode, Range("J7"), Range("B8"))でサブプロシージャS_KanaConverterを呼び、セル「B8」にかしら字を自動挿入します。
サブプロシージャS_KanaConverterについては、後ほど解説します。
「Case Not Intersect(Target, Range(“N10”)) Is Nothing」の場合
Set myCell = Range("N10")と、対象となるセルが「N10」となっている以外は、セル「J8」の場合と全く一緒です。
「Case Not Intersect(Target, Range(“I13”)) Is Nothing」の場合
セル「I13」は郵便番号欄です。
郵便番号は「123-4567」のように「数字3桁＋ハイフン＋数字4桁」で表します。
このセルの文字列の長さで、4つに分類し、Select Case ～～～ End Selectで処理を分岐しています。
セル「I13」の文字列の長さが「8」の場合は、郵便番号が入力されている可能性が高いので、If F_CheckUpZip(myCell.Value) = False Then Exit Subで文字列が郵便番号の形式に合っているかどうかをチェックし、If F_CheckUpBook = False Then Exit Subでzenkoku.xlsmが開いているかどうかをチェックし、If F_CheckUpSheet = False Then Exit Subでzenkokuワークシートが存在しているかどうかをチェックし、Call S_DisplayAddress(myCell.Value)でセル「O12」に住所（漢字）を、セル「P11」に住所（カナ）を自動表示します。
セル「I13」の文字列の長さが「17」の場合は、「数字3桁＋ハイフン＋数字4桁」＋「改行文字」＋「数字3桁＋ハイフン＋数字4桁」の形式になっている可能性が高いので、改行文字があるかないかで処理を分岐します。改行文字がない場合は、セル「I13」・セル「O12」・セル「P11」を空白にします。改行文字がある場合は、郵便番号が二段に渡って入力されたとしてチェックします。
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_CheckUpBook = False Then Exit Subでzenkoku.xlsmが開いているかどうかをチェックし、If F_CheckUpSheet = False Then Exit Subでzenkokuワークシートが存在しているかどうかをチェックします。
Call S_DisplayAddress2(my1stValue, my2ndValue)で、セル「I13」に郵便番号を二段書きで、セル「O12」に住所（漢字）を二段書きで、セル「P11」に住所（カナ）を二段書きで自動表示します。
セル「I13」の文字列の長さが「0」の場合＝DELETEキーを押すなどしてセル「I13」が空白の場合、アクティブセルをセル「O12」に移動します。
セル「I13」の文字列の長さがその他の数字の場合は、セル「I13」「O12」「P11」を空白にします。
「Case Not Intersect(Target, Range(“O12”)) Is Nothing」の場合
Set myCell = Range("O12")と、対象となるセルが「O12」となっている以外は、セル「J8」の場合と全く一緒です。
「Case Not Intersect(Target, Range(“P11”)) Is Nothing」の場合
Set myCell = Range("P11")と、対象となるセルが「P11」となっている以外は、セル「J8」の場合と全く一緒です。
「Case Not Intersect(Target, Range(“D19”)) Is Nothing」の場合
セル「D19」には持出銀行名が入力されます。
持出銀行名が二段書きになる場合、二段目の銀行名の前に左カッコ（が付きます。
セル「J8」の場合と違うのは、If (InStr(myCell.Value, "（") = 0) And (myLf > 0) Thenとmy2ndValue = "（" & Mid(myCell.Value, myLf + 1)の部分です。
If (InStr(myCell.Value, "（") = 0) And (myLf > 0) Thenで、セル「D19」の値に（が含まれるかどうか、改行文字が含まれるかどうかを調べます。
my2ndValue = "（" & Mid(myCell.Value, myLf + 1)で二段目の銀行名の前に（を付与します。
「Case Not Intersect(Target, Range(“O19”)) Is Nothing」の場合
セル「O19」には持出支店名が入力されます。
持出支店名が二段書きになる場合、二段目の視点名の後に右カッコ）が付きます。
セル「D19」の場合と違うのは、If (InStr(myCell.Value, "）") = 0) And (myLf > 0) Thenとmy2ndValue = Mid(myCell.Value, myLf + 1) & "）"の部分です。
If (InStr(myCell.Value, "）") = 0) And (myLf > 0) Thenで、セル「O19」の値に）が含まれるかどうか、改行文字が含まれるかどうかを調べます。
my2ndValue = Mid(myCell.Value, myLf + 1) & "）"で二段目の支店名の後に）を付与します。
「S_KanaConverter」サブプロシージャの解説
次に、Worksheet_Changeから呼び出されるS_KanaConverterを解説します。セル「J7」のフリガナが変化したときに呼び出されます。
このプロシージャは、3つの変数を取ります。
カタカナ1文字の文字コードを格納している変数myCode、フリガナが入力されているセルを格納するオブジェクト変数Katakana、変換後のかしら字を入力するセルを格納するオブジェクト変数Hiraganaの3つです。
まず、myCodeに格納されている文字コードを調べます。
その文字コードの値が、「12449より小さい」または「12532より大きい」場合は、その文字コードで表される文字はカタカナではないので、KatakanaのセルとHiraganaのセルをクリアします。
そうでない場合、つまり変数myCodeの値を文字コードとして取る文字がカタカナの場合、その文字コードの値によってSelect Case ～ End Selectで分岐し、整理してからカタカナからひらがなに変換しています。
この部分は、ひらがな・カタカナ相互変換プログラム – Evaluateメソッドの使い方の7.文字コードの整理を参考にしてください。
参考部分に書いてある3つの性質と例外については、本プログラムに応用できます。
「S_NormalConverter」サブプロシージャの解説
ここからは、S_KanaConverterから呼び出されるサブプロシージャの解説をしていきます。
このサブプロシージャは、カタカナ1文字をひらがな1文字に変換します。
例えば、カタカナの「カ」のユニコード文字番号は「12459」であり、ひらがなの「か」のユニコード文字番号は「12363」です。
この番号の差を取ると、その差は「96」です。
このことから引き算するとひらがなのユニコード文字番号が求められます。
あとはUnichar関数を使って、Hiragana.Value = WorksheetFunction.Unichar(myCode - 96)でひらがなを求めるだけです。
Unichar関数はCHARワークシート関数のユニコード版です。
「S_ModTwo_1」サブプロシージャと「S_ModTwo_2」サブプロシージャの解説
Mod演算子は、割り算の余りを求める演算子です。
あるユニコード文字番号を2で割ると、ユニコード文字番号は整数ですから余りは0か1です。
例えば、「カ」のユニコード文字番号は「12459」であり、「ガ」のユニコード文字番号は「12460」です。
ですので、「カ」のユニコード文字番号「12459」を2で割ると余りは「1」、「ガ」のユニコード文字番号「12460」を2で割ると余りは「0」です。
したがって、ひらがなの「か」のユニコード文字番号を求めるには、カタカナの「カ」の場合は直接ユニコード文字番号から「96」を引き、カタカナの「ガ」の場合はまず「1」を引いてからユニコード文字番号から「96」を引きます。
また、ひらがなの「て」のユニコード文字番号を求めるには、カタカナの「テ」の場合はまず「1」を引いてからユニコード文字番号から「96」を引き、カタカナの「デ」の場合は直接ユニコード文字番号から「96」を引きます。
以上の仕組みをVBAで表現すると、Select Case ～ End Selectで余りが「0」と「1」の場合に分け、それぞれの場合の処理をします。実際の処理はS_NormalConverterに任せていますので、S_ModTwo_1サブプロシージャとS_ModTwo_2サブプロシージャの役割は主にユニコード文字番号の分類です。
「S_ModThree」サブプロシージャの解説
S_ModThreeサブプロシージャの役割も主にユニコード文字番号の分類です。
「ハ」のユニコード文字番号は「12495」であり、「バ」のユニコード文字番号は「12496」であり、「パ」のユニコード文字番号は「12497」です。
したがって、ひらがなの「は」のユニコード文字番号を求めるには、カタカナの「ハ」の場合は直接ユニコード文字番号から「96」を引き、カタカナの「バ」の場合はまず「1」を引いてからユニコード文字番号から「96」を引き、カタカナの「パ」の場合はまず「1」を引いてからユニコード文字番号から「96」を引きます。
「S_VConverter」サブプロシージャの解説
「ヴ」の場合は、「う」に変換します。
「S_DisplayAddress」サブプロシージャ・「S_DisplayAddress2」サブプロシージャの解説
「S_DisplayAddress」サブプロシージャと「S_DisplayAddress2」サブプロシージャは、郵便番号からその住所とフリガナを検索・表示するプロシージャです。
この2つのプロシージャの違いは、引数が郵便番号1つか、2つかの違いだけです。
このプロシージャのポイントはMatchワークシート関数の使い方です。Match関数は検索範囲内での相対的な位置を数字で返します。
MATCHワークシート関数の書式は、Match(Lookup_value , Lookup_array , Match_type)ですので、Lookup_valueは検査値であり、値 (数値、文字列、または論理値)、またはこれらの値に対するセル参照を指定できます。
Lookup_arrayは検索範囲であり、検索するセルの範囲を指定します。
Match_typeは照合の型であり、-1、0、1 の数値のいずれかを指定します。「0」の場合は検査値と等しい最初の値を検索します。検査範囲の引数の値は、任意の順序で指定できます。つまり、わざわざ昇順や降順で並べ替えておく必要はない、ということです。
Set myCell = .Cells(WorksheetFunction.Match(myZip, .Range(.Cells(2, 1), .Cells(myRow, 1)), 0) + 1, 1)という記述では、検査値はmyZipであり、検索範囲は.Range(.Cells(2, 1), .Cells(myRow, 1))です。
つまり、郵便番号を縦1列の検索範囲から探して、上から何番目にあるかを数字で返します。検索範囲は2行目から最終行までの範囲です。絶対的な行数を求めるにはMatch関数で返される値に1を足します。
最後にセル「O12」に漢字住所を、セル「P11」にカナ住所を表示します。
おわりに
今回は、不渡届というマイナーな書式を題材にして、帳票の入力支援システムを考えてみました。
実際、題材は何でもいいと思います。
伝えたかったのは、PCに不慣れな方に入力作業を担当していただくためには、私たちがよく使うエクセルの関数や標準モジュールのプログラムだけではなく、書式設定や条件付書式、入力規則、ブックモジュールやシートモジュールのプログラムを総動員しないと、入力担当者に使いやすいシステムは作れない、ということでした。
また、本当ならば、入力シートと出力シートは別にしたほうがいいでしょう。
しかし、今回はPCにまったく不慣れな方を入力担当者にするというイメージで、それなら入力シートを実際の帳票に似せて作った方が入力しやすいと思い、今回のような作例になりました。
データ蓄積用のフォーマットは何でもいいと思います。同じファイルに別シートを用意し、そこにデータを格納してもよいですし、アクセスと連携してデータベースファイルを用意してもいいと思います。
この記事を読んで、自分なりのシステムを組んでいただけたら幸いです。
コメントを残す