（1）フォームを使った仕訳伝票
ボタンの呼び出し
Sub 仕訳伝票フォーム()
frmsiwake.Show
End Sub
日付入力のチェック
入力後エンターを押した時キーコードを判断する
If KeyCode = vbKeyReturn
日付の長さLen(txthiduke.Text)を判断し8桁から10桁のみ入力可能にしている。
Private Sub txthiduke_KeyDown(ByVal KeyCode As MSForms.ReturnInteger, ByVal Shift As Integer)
If KeyCode = vbKeyReturn Then
Select Case Len(txthiduke.Text)
Case 0 To 2
MsgBox "桁数が少ない(12/3)"
Exit Sub
Case 6 To 7
MsgBox "桁数が少ない(2012/12/3) "
Exit Sub
Case Is >= 11
MsgBox "桁数が多い "
Exit Sub
End Select
End If
End Sub
仕訳伝票フォームのキャンセル
Private Sub cmdCancel_Click()
Unload Me
End Sub
科目コードを直接入力したとき科目名を検索する関数
標準モジュールに記述
Function kamokukensakuf(kcode As Long) As String
Dim lastrow As Long
Dim i As Long
lastrow = Worksheets("科目表").Cells(Rows.Count, 1).End(xlUp).Row
For i = 2 To lastrow
If kcode = Worksheets("科目表").Cells(i, 1) Then
kamokukensakuf = Worksheets("科目表").Cells(i, 2)
Exit Function
End If
Next
kamokukensakuf = ""
MsgBox "科目コードがみつかりません"
End Function
仕訳帳シートに追加登録する。
フォームのオブジェクトを仕訳帳シートに追加するがフォームのオブジェクトは配列が
使えないためCollectionとAdd Itemを使っての３０個のオブジェクトを作成する。
借方コード、借方名、金額、貸方コード、貸方名、摘要と６ｘ５行分のオブジェクトを書いている、またCollectionを使ってプロシージャの外側に書いているためそのモジュール全体で使えるようにしている。
Private myCollectrc As New Collection
Private myCollectrn As New Collection
Private myCollectki As New Collection
Private myCollectsc As New Collection
Private myCollectsn As New Collection
Private myCollecttk As New Collection
フォームを呼び出したときに３０個のCollectionを作っている。
Private Sub UserForm_Initialize()
'借方コード
With myCollectrc
.Add Item:=txtkaric1
.Add Item:=txtkaric2
.Add Item:=txtkaric3
.Add Item:=txtkaric4
.Add Item:=txtkaric5
End With
'借方科目
With myCollectrn
.Add Item:=lblkarin1
.Add Item:=lblkarin2
.Add Item:=lblkarin3
.Add Item:=lblkarin4
.Add Item:=lblkarin5
End With
'金額
With myCollectki
.Add Item:=txtkingaku1
.Add Item:=txtkingaku2
.Add Item:=txtkingaku3
.Add Item:=txtkingaku4
.Add Item:=txtkingaku5
End With
'貸方コード
With myCollectsc
.Add Item:=txtkasic1
.Add Item:=txtkasic2
.Add Item:=txtkasic3
.Add Item:=txtkasic4
.Add Item:=txtkasic5
End With
'貸方科目
With myCollectsn
.Add Item:=lblkasin1
.Add Item:=lblkasin2
.Add Item:=lblkasin3
.Add Item:=lblkasin4
.Add Item:=lblkasin5
End With
'摘要
With myCollecttk
.Add Item:=txttekiyou1
.Add Item:=txttekiyou2
.Add Item:=txttekiyou3
.Add Item:=txttekiyou4
.Add Item:=txttekiyou5
End With
End Sub
5行の固定入力画面であるが、入力されている行のみ登録している
借方科目コードが入力されているかで判断している。
Private Sub cmdtouroku_Click()
Dim lastrow As Long
Dim i As Long
lastrow = Worksheets("仕訳帳").Cells(Rows.Count, 1).End(xlUp).Row
For i = 1 To 5
If myCollectrc(i).Text <> "" Then
Worksheets("仕訳帳").Cells(lastrow + i, 1) = txthiduke.Text
Worksheets("仕訳帳").Cells(lastrow + i, 2) = myCollectrc(i).Text
Worksheets("仕訳帳").Cells(lastrow + i, 2) = myCollectrn(i).Caption
Worksheets("仕訳帳").Cells(lastrow + i, 4) = myCollectki(i).Text
Worksheets("仕訳帳").Cells(lastrow + i, 5) = myCollectsc(i).Text
Worksheets("仕訳帳").Cells(lastrow + i, 6) = myCollectsn(i).Caption
Worksheets("仕訳帳").Cells(lastrow + i, 7) = myCollectki(i).Text
Worksheets("仕訳帳").Cells(lastrow + i, 8) = myCollecttk(i).Text
End If
Next
txthiduke.Text = ""
For i = 1 To 5
myCollectrc(i).Text = ""
myCollectrn(i).Caption = ""
myCollectki(i).Text = ""
myCollectsc(i).Text = ""
myCollectsn(i).Caption = ""
myCollecttk(i).Text = ""
Next
End Sub
科目コードのHELP画面を使って入力をしやすくする。
科目検索フォームに記述している
伝票入力の科目コードでスペースキーを押したときに表示するようにしているために
m_lngkamokucとm_strkamokuNmの変数を使ってPlbshowDialogの関数の引数を0
か1で判断して科目コード・科目名を仕訳伝票に持ってきている。
Private m_lngkamokuc As Long
Private m_strkamokuNm As String
Private Sub cmdCancel_Click()
Unload Me
End Sub
Private Sub cmdJikkou_Click()
If kamokulist.ListIndex = -1 Then Exit Sub
m_lngkamokuc = kamokulist.Value
m_strkamokuNm = kamokulist.List(kamokulist.ListIndex, 1)
Me.Hide
End Sub
Private Sub UserForm_Initialize()
Dim i As Long
Dim lastrow As Long
lastrow = Worksheets("科目表").Cells(Rows.Count, 1).End(xlUp).Row
kamokulist.ColumnCount = 2
For i = 2 To lastrow
With kamokulist
.AddItem
.List(i - 2, 0) = Worksheets("科目表").Cells(i, 1)
.List(i - 2, 1) = Worksheets("科目表").Cells(i, 2)
End With
Next
End Sub
Private Sub kamokulist_DblClick(ByVal Cancel As MSForms.ReturnBoolean)
If kamokulist.ListIndex = -1 Then Exit Sub
m_lngkamokuc = kamokulist.Value
m_strkamokuNm = kamokulist.List(kamokulist.ListIndex, 1)
Me.Hide
End Sub
Public Function PlbshowDialog(rlngkamokuc As Long, Optional rstrkamokuNm As String) As Long
PlbshowDialog = -1
Me.Show vbModal
If m_lngkamokuc <> 0 Then
rlngkamokuc = m_lngkamokuc
rstrkamokuNm = m_strkamokuNm
PlbshowDialog = 0
End If
End Function
各行の借方コード・貸方コード１０個のプロシージャを書いている
先ほど述べたようにオブジェクトの配列が使えないために、単純に１０個記述している。
コード入力の項目でコード番号入力後エンターを押したときの処理
vbKeyReturnを判断して、kamokukensakufの関数で科目名を検索している。
何も入力しないでスペースを押したときの処理
vbKeySpaceを判断して、
intShowStatus = frmkamoku.PlbshowDialog(lngkamokuc, strkamokuNm)
If intShowStatus <> 0 Then Exit Sub
でHELP検索の画面に飛び科目コード番号科目名を持ってくる
Private Sub txtkaric1_KeyDown(ByVal KeyCode As MSForms.ReturnInteger, ByVal Shift As Integer)
Dim intShowStatus As Long
Dim lngkamokuc As Long
Dim strkamokuNm As String
Select Case KeyCode
Case vbKeySpace
intShowStatus = frmkamoku.PlbshowDialog(lngkamokuc, strkamokuNm)
If intShowStatus <> 0 Then Exit Sub
Case vbKeyReturn
If txtkaric1.Text = "" Then
Exit Sub
End If
lblkarin1.Caption = kamokukensakuf(txtkaric1.Text)
Exit Sub
Case Else
Exit Sub
End Select
txtkaric1.Text = lngkamokuc
lblkarin1.Caption = strkamokuNm
End Sub
Private Sub txtkaric2_KeyDown(ByVal KeyCode As MSForms.ReturnInteger, ByVal Shift As Integer)
Dim intShowStatus As Long
Dim lngkamokuc As Long
Dim strkamokuNm As String
Select Case KeyCode
Case vbKeySpace
intShowStatus = frmkamoku.PlbshowDialog(lngkamokuc, strkamokuNm)
If intShowStatus <> 0 Then Exit Sub
Case vbKeyReturn
If txtkaric2.Text = "" Then
Exit Sub
End If
lblkarin2.Caption = kamokukensakuf(txtkaric2.Text)
Exit Sub
Case Else
Exit Sub
End Select
txtkaric2.Text = lngkamokuc
lblkarin2.Caption = strkamokuNm
End Sub
Private Sub txtkaric3_KeyDown(ByVal KeyCode As MSForms.ReturnInteger, ByVal Shift As Integer)
Dim intShowStatus As Long
Dim lngkamokuc As Long
Dim strkamokuNm As String
Select Case KeyCode
Case vbKeySpace
intShowStatus = frmkamoku.PlbshowDialog(lngkamokuc, strkamokuNm)
If intShowStatus <> 0 Then Exit Sub
Case vbKeyReturn
If txtkaric3.Text = "" Then
Exit Sub
End If
lblkarin3.Caption = kamokukensakuf(txtkaric3.Text)
Exit Sub
Case Else
Exit Sub
End Select
txtkaric3.Text = lngkamokuc
lblkarin3.Caption = strkamokuNm
End Sub
Private Sub txtkaric4_KeyDown(ByVal KeyCode As MSForms.ReturnInteger, ByVal Shift As Integer)
Dim intShowStatus As Long
Dim lngkamokuc As Long
Dim strkamokuNm As String
Select Case KeyCode
Case vbKeySpace
intShowStatus = frmkamoku.PlbshowDialog(lngkamokuc, strkamokuNm)
If intShowStatus <> 0 Then Exit Sub
Case vbKeyReturn
If txtkaric4.Text = "" Then
Exit Sub
End If
lblkarin4.Caption = kamokukensakuf(txtkaric4.Text)
Exit Sub
Case Else
Exit Sub
End Select
txtkaric4.Text = lngkamokuc
lblkarin4.Caption = strkamokuNm
End Sub
Private Sub txtkaric5_KeyDown(ByVal KeyCode As MSForms.ReturnInteger, ByVal Shift As Integer)
Dim intShowStatus As Long
Dim lngkamokuc As Long
Dim strkamokuNm As String
Select Case KeyCode
Case vbKeySpace
intShowStatus = frmkamoku.PlbshowDialog(lngkamokuc, strkamokuNm)
If intShowStatus <> 0 Then Exit Sub
Case vbKeyReturn
If txtkaric5.Text = "" Then
Exit Sub
End If
lblkarin5.Caption = kamokukensakuf(txtkaric5.Text)
Exit Sub
Case Else
Exit Sub
End Select
txtkaric5.Text = lngkamokuc
lblkarin5.Caption = strkamokuNm
End Sub
Private Sub txtkasic1_KeyDown(ByVal KeyCode As MSForms.ReturnInteger, ByVal Shift As Integer)
Dim intShowStatus As Long
Dim lngkamokuc As Long
Dim strkamokuNm As String
Select Case KeyCode
Case vbKeySpace
intShowStatus = frmkamoku.PlbshowDialog(lngkamokuc, strkamokuNm)
If intShowStatus <> 0 Then Exit Sub
Case vbKeyReturn
If txtkasic1.Text = "" Then
Exit Sub
End If
lblkasin1.Caption = kamokukensakuf(txtkasic1.Text)
Exit Sub
Case Else
Exit Sub
End Select
txtkasic1.Text = lngkamokuc
lblkasin1.Caption = strkamokuNm
End Sub
Private Sub txtkasic2_KeyDown(ByVal KeyCode As MSForms.ReturnInteger, ByVal Shift As Integer)
Dim intShowStatus As Long
Dim lngkamokuc As Long
Dim strkamokuNm As String
Select Case KeyCode
Case vbKeySpace
intShowStatus = frmkamoku.PlbshowDialog(lngkamokuc, strkamokuNm)
If intShowStatus <> 0 Then Exit Sub
Case vbKeyReturn
If txtkasic2.Text = "" Then
Exit Sub
End If
lblkasin2.Caption = kamokukensakuf(txtkasic2.Text)
Exit Sub
Case Else
Exit Sub
End Select
txtkasic2.Text = lngkamokuc
lblkasin2.Caption = strkamokuNm
End Sub
Private Sub txtkasic3_KeyDown(ByVal KeyCode As MSForms.ReturnInteger, ByVal Shift As Integer)
Dim intShowStatus As Long
Dim lngkamokuc As Long
Dim strkamokuNm As String
Select Case KeyCode
Case vbKeySpace
intShowStatus = frmkamoku.PlbshowDialog(lngkamokuc, strkamokuNm)
If intShowStatus <> 0 Then Exit Sub
Case vbKeyReturn
If txtkasic3.Text = "" Then
Exit Sub
End If
lblkasin3.Caption = kamokukensakuf(txtkasic3.Text)
Exit Sub
Case Else
Exit Sub
End Select
txtkasic3.Text = lngkamokuc
lblkasin3.Caption = strkamokuNm
End Sub
Private Sub txtkasic4_KeyDown(ByVal KeyCode As MSForms.ReturnInteger, ByVal Shift As Integer)
Dim intShowStatus As Long
Dim lngkamokuc As Long
Dim strkamokuNm As String
Select Case KeyCode
Case vbKeySpace
intShowStatus = frmkamoku.PlbshowDialog(lngkamokuc, strkamokuNm)
If intShowStatus <> 0 Then Exit Sub
Case vbKeyReturn
If txtkasic4.Text = "" Then
Exit Sub
End If
lblkasin4.Caption = kamokukensakuf(txtkasic4.Text)
Exit Sub
Case Else
Exit Sub
End Select
txtkasic4.Text = lngkamokuc
lblkasin4.Caption = strkamokuNm
End Sub
Private Sub txtkasic5_KeyDown(ByVal KeyCode As MSForms.ReturnInteger, ByVal Shift As Integer)
Dim intShowStatus As Long
Dim lngkamokuc As Long
Dim strkamokuNm As String
Select Case KeyCode
Case vbKeySpace
intShowStatus = frmkamoku.PlbshowDialog(lngkamokuc, strkamokuNm)
If intShowStatus <> 0 Then Exit Sub
Case vbKeyReturn
If txtkasic5.Text = "" Then
Exit Sub
End If
lblkasin5.Caption = kamokukensakuf(txtkasic5.Text)
Exit Sub
Case Else
Exit Sub
End Select
txtkasic5.Text = lngkamokuc
lblkasin5.Caption = strkamokuNm
End Sub