アクセス小僧：月ごとの領収書番号(3) [コンピューター]
アクセス小僧：月ごとの領収書番号(2)
http://cheese999.blog.so-net.ne.jp/2016-12-23-1
で紹介した、医療費控除の医療費を月ごとに集計するためのアクセスのデータベースにおいて
領収書番号を自動で入力するマクロですが、うまく動かないので見直し中です。
【データベース】
・病院、薬局でもらってくる領収書１枚ごとに、１レコード登録する。
・レコードは、受診した順番に登録し、ユニークな番号としてID（昇順）につける。
・レコードには、受診した日付も登録する。
・領収書番号は、月ごとに1,2,3,--と付ける。同じ日に複数受診した場合、IDの順に番号を振る。
【マクロの内容】
・領収書を登録するフォームに、領収書番号を自動で入力するマクロを呼ぶボタンを配置する。
・マクロは、データベースから、同じ月のレコードを検索して、配列に格納する。
・配列に格納されたレコードが1件なら、領収書番号を1にしてマクロを終了する。
・配列のレコードを日付、IDで昇順にソートし、領収書番号を1,2,3,--と振り、マクロを呼んだレコードの領収書番号を返す。
【マクロのコード】
(1) フォームのボタンをクリックしたら呼ばれるマクロ
Private Sub 領収書番号更新_Click()
If IsNull([ID]) Then
' 新規レコードでは、IDがnullなので、9999としておく
[領収書番号] = SetRyouSyuNo1([日付], [領収書番号], [日付], 9999)
Else
[領収書番号] = SetRyouSyuNo1([日付], [領収書番号], [日付], [ID])
End If
End Sub
・日付とIDをレコードから拾って、SetRyouSyuNo1マクロに渡す。
・マクロはフォームに記述する。
(2) 日付とIDから、領収書番号を返すマクロ(SetRyouSyuNo1)
・マクロを標準モジュールに記述する。
Public Function SetRyouSyuNo1(Optional Ctl As Control, Optional Ctl2 As Control, _
Optional MyDate2 As Date, Optional myID As Integer) As Integer
' 【機能】月が変わったら、領収書番号を1にする
' 【引数】
' Ctl : 日付のコントロール
' Ctl2 : 領収書番号のコントロール
' MyDate2 : 現在のレコードの日付
' myID : ID
' 【変数】
Dim myDate1(2) As Date ' 日付
Dim myYear1(2) As Integer ' 年
Dim myMonth1(2) As Integer ' 月
Dim myDay1(2) As Integer ' 日
Dim myRyNo1(3) As Integer ' 領収書番号
Dim db1 As DAO.Database ' データベース
Dim rs1 As DAO.Recordset ' レコードセット
Dim rcdNo1(2) As Long ' レコード番号
Dim myID1(2) As Integer ' ID
Dim myCntRcd1 As Integer ' 同じ年月のレコード件数
Dim i, j, k As Integer ' for文のカウンタ
' 【コード】
'※ CodeContextObjectがエラーになるのでコメント化
'※ カレントレコードのレコード番号が1以下だったら、終了
'※ If CodeContextObject.CurrentRecord <= 1 Then
'※ SetRyouSyuNo1 = 1
'※ Exit Function
'※ End If
' 医療費テーブルをレコードセットとして開く
Set db1 = CurrentDb()
' dbOpenTableだと、absolutepositionが使えない
' Set rs1 = db1.OpenRecordset("T_医療費", dbOpenTable)
Set rs1 = db1.OpenRecordset("T_医療費", dbOpenDynaset)
If rs1.EOF Then
MsgBox "医療費テーブルにレコードがありません。"
SetRyouSyuNo1 = 1
Exit Function
Else
rs1.MoveLast
' MsgBox "全レコード件数=" & rs1.RecordCount
rs1.MoveFirst
End If
' 最大の領収書番号
myRyNo1(2) = 0
' myIDがnullなら、9999にしておく
If IsNull(myID) Then
myID1(1) = 9999
Else
myID1(1) = myID
End If
' 現在のレコードの年、月、日
myYear1(1) = Year(MyDate2)
myMonth1(1) = Month(MyDate2)
myDay1(1) = Day(MyDate2)
' 同じ年月のレコード件数
myCntRcd1 = 0
' 1番の領収書番号のレコードのレコード番号、日、ID
rcdNo1(2) = 9999 ' レコード番号
myDay1(2) = 32 ' 日
myID1(2) = 9999 ' ID
Do Until rs1.EOF
' レコードの年、月、日
myYear1(0) = Year(rs1!日付)
myMonth1(0) = Month(rs1!日付)
myDay1(0) = Day(rs1!日付)
myID1(0) = rs1!ID
' 同じ年月
If (myYear1(0) = myYear1(1)) And (myMonth1(0) = myMonth1(1)) Then
myCntRcd1 = myCntRcd1 + 1 ' 同じ年月のレコード件数
' 1番の領収書番号のレコードを探す
If (myDay1(0) < myDay1(2)) Or _
((myDay1(0) = myDay1(2)) And (myID1(0) < myID1(2))) Then
rcdNo1(2) = rs1.AbsolutePosition ' レコード番号
myDay1(2) = myDay1(0) ' 日
myID1(2) = myID1(0) ' ID
End If
End If
rs1.MoveNext
Loop
' MsgBox myYear1(1) & "年" & myMonth1(1) & "月のレコード件数=" & myCntRcd1
' MsgBox "rcdNo1(2)=" & rcdNo1(2)
' 同じ年月のレコードが他に無い
If myCntRcd1 = 1 Then
MsgBox ("日付=" & MyDate2 & vbCrLf & _
"領収書番号=1" & vbCrLf & _
"ID=" & myID & vbCrLf & _
"レコード番号=" & rcdNo1(2))
' 領収書番号を1にする
SetRyouSyuNo1 = 1
' レコードセットを閉じる
rs1.Close: Set rs1 = Nothing
db1.Close: Set db1 = Nothing
Exit Function
End If
rs1.MoveFirst
' 同じ年月のレコードを格納する配列を定義
Dim myRcd1()
i = 0 ' カウンタ初期化
Do Until rs1.EOF
' レコードの年、月、日
myYear1(0) = Year(rs1!日付)
myMonth1(0) = Month(rs1!日付)
myDay1(0) = Day(rs1!日付)
myID1(0) = rs1!ID
' 同じ年月
If (myYear1(0) = myYear1(1)) And (myMonth1(0) = myMonth1(1)) Then
' MsgBox "i=" & i ' debug
ReDim Preserve myRcd1(4, i)
myRcd1(0, i) = rs1.AbsolutePosition ' レコード番号
myRcd1(1, i) = myDay1(0) ' 日
myRcd1(2, i) = myID1(0) ' ID
If myRcd1(0, i) = rcdNo1(2) Then
myRcd1(3, i) = 1 ' 領収書番号
If myRcd1(2, i) = myID Then
SetRyouSyuNo1 = 1
Exit Function
End If
' MsgBox "myRcd1(0, i)=" & myRcd1(0, i)
Else
myRcd1(3, i) = 0 ' 領収書番号
End If
If myID1(0) = myID Then
myRcd1(4, i) = 1 ' Flag(ID一致)
Else
myRcd1(4, i) = 0 ' Flag
End If
i = i + 1
End If
rs1.MoveNext
Loop
' レコードセットを閉じる
rs1.Close: Set rs1 = Nothing
db1.Close: Set db1 = Nothing
myDay1(2) = 32 ' 日
myID1(2) = 9999 ' ID
myRyNo1(3) = 1 ' 現在の領収書番号
For i = 0 To myCntRcd1 - 2
For j = 0 To myCntRcd1 - 1
If (myRcd1(3, j) = 0) And _
((myRcd1(1, j) < myDay1(2)) Or _
((myRcd1(1, j) = myDay1(2)) And (myRcd1(2, j) < myID1(2)))) Then
myDay1(2) = myRcd1(1, j) ' 日
myID1(2) = myRcd1(2, j) ' ID
k = j
End If
Next j
myRyNo1(3) = myRyNo1(3) + 1 ' 現在の領収書番号
myRcd1(3, k) = myRyNo1(3)
If myID = myRcd1(2, k) Then
SetRyouSyuNo1 = myRyNo1(3)
End If
' MsgBox "k=" & k & " myID1(2) =" & myID1(2) & " myRcd1(3, k) =" & myRcd1(3, k)
myDay1(2) = 32 ' 日
myID1(2) = 9999 ' ID
Next i
End Function
http://cheese999.blog.so-net.ne.jp/2016-12-23-1
で紹介した、医療費控除の医療費を月ごとに集計するためのアクセスのデータベースにおいて
領収書番号を自動で入力するマクロですが、うまく動かないので見直し中です。
【データベース】
・病院、薬局でもらってくる領収書１枚ごとに、１レコード登録する。
・レコードは、受診した順番に登録し、ユニークな番号としてID（昇順）につける。
・レコードには、受診した日付も登録する。
・領収書番号は、月ごとに1,2,3,--と付ける。同じ日に複数受診した場合、IDの順に番号を振る。
【マクロの内容】
・領収書を登録するフォームに、領収書番号を自動で入力するマクロを呼ぶボタンを配置する。
・マクロは、データベースから、同じ月のレコードを検索して、配列に格納する。
・配列に格納されたレコードが1件なら、領収書番号を1にしてマクロを終了する。
・配列のレコードを日付、IDで昇順にソートし、領収書番号を1,2,3,--と振り、マクロを呼んだレコードの領収書番号を返す。
【マクロのコード】
(1) フォームのボタンをクリックしたら呼ばれるマクロ
Private Sub 領収書番号更新_Click()
If IsNull([ID]) Then
' 新規レコードでは、IDがnullなので、9999としておく
[領収書番号] = SetRyouSyuNo1([日付], [領収書番号], [日付], 9999)
Else
[領収書番号] = SetRyouSyuNo1([日付], [領収書番号], [日付], [ID])
End If
End Sub
・日付とIDをレコードから拾って、SetRyouSyuNo1マクロに渡す。
・マクロはフォームに記述する。
(2) 日付とIDから、領収書番号を返すマクロ(SetRyouSyuNo1)
・マクロを標準モジュールに記述する。
Public Function SetRyouSyuNo1(Optional Ctl As Control, Optional Ctl2 As Control, _
Optional MyDate2 As Date, Optional myID As Integer) As Integer
' 【機能】月が変わったら、領収書番号を1にする
' 【引数】
' Ctl : 日付のコントロール
' Ctl2 : 領収書番号のコントロール
' MyDate2 : 現在のレコードの日付
' myID : ID
' 【変数】
Dim myDate1(2) As Date ' 日付
Dim myYear1(2) As Integer ' 年
Dim myMonth1(2) As Integer ' 月
Dim myDay1(2) As Integer ' 日
Dim myRyNo1(3) As Integer ' 領収書番号
Dim db1 As DAO.Database ' データベース
Dim rs1 As DAO.Recordset ' レコードセット
Dim rcdNo1(2) As Long ' レコード番号
Dim myID1(2) As Integer ' ID
Dim myCntRcd1 As Integer ' 同じ年月のレコード件数
Dim i, j, k As Integer ' for文のカウンタ
' 【コード】
'※ CodeContextObjectがエラーになるのでコメント化
'※ カレントレコードのレコード番号が1以下だったら、終了
'※ If CodeContextObject.CurrentRecord <= 1 Then
'※ SetRyouSyuNo1 = 1
'※ Exit Function
'※ End If
' 医療費テーブルをレコードセットとして開く
Set db1 = CurrentDb()
' dbOpenTableだと、absolutepositionが使えない
' Set rs1 = db1.OpenRecordset("T_医療費", dbOpenTable)
Set rs1 = db1.OpenRecordset("T_医療費", dbOpenDynaset)
If rs1.EOF Then
MsgBox "医療費テーブルにレコードがありません。"
SetRyouSyuNo1 = 1
Exit Function
Else
rs1.MoveLast
' MsgBox "全レコード件数=" & rs1.RecordCount
rs1.MoveFirst
End If
' 最大の領収書番号
myRyNo1(2) = 0
' myIDがnullなら、9999にしておく
If IsNull(myID) Then
myID1(1) = 9999
Else
myID1(1) = myID
End If
' 現在のレコードの年、月、日
myYear1(1) = Year(MyDate2)
myMonth1(1) = Month(MyDate2)
myDay1(1) = Day(MyDate2)
' 同じ年月のレコード件数
myCntRcd1 = 0
' 1番の領収書番号のレコードのレコード番号、日、ID
rcdNo1(2) = 9999 ' レコード番号
myDay1(2) = 32 ' 日
myID1(2) = 9999 ' ID
Do Until rs1.EOF
' レコードの年、月、日
myYear1(0) = Year(rs1!日付)
myMonth1(0) = Month(rs1!日付)
myDay1(0) = Day(rs1!日付)
myID1(0) = rs1!ID
' 同じ年月
If (myYear1(0) = myYear1(1)) And (myMonth1(0) = myMonth1(1)) Then
myCntRcd1 = myCntRcd1 + 1 ' 同じ年月のレコード件数
' 1番の領収書番号のレコードを探す
If (myDay1(0) < myDay1(2)) Or _
((myDay1(0) = myDay1(2)) And (myID1(0) < myID1(2))) Then
rcdNo1(2) = rs1.AbsolutePosition ' レコード番号
myDay1(2) = myDay1(0) ' 日
myID1(2) = myID1(0) ' ID
End If
End If
rs1.MoveNext
Loop
' MsgBox myYear1(1) & "年" & myMonth1(1) & "月のレコード件数=" & myCntRcd1
' MsgBox "rcdNo1(2)=" & rcdNo1(2)
' 同じ年月のレコードが他に無い
If myCntRcd1 = 1 Then
MsgBox ("日付=" & MyDate2 & vbCrLf & _
"領収書番号=1" & vbCrLf & _
"ID=" & myID & vbCrLf & _
"レコード番号=" & rcdNo1(2))
' 領収書番号を1にする
SetRyouSyuNo1 = 1
' レコードセットを閉じる
rs1.Close: Set rs1 = Nothing
db1.Close: Set db1 = Nothing
Exit Function
End If
rs1.MoveFirst
' 同じ年月のレコードを格納する配列を定義
Dim myRcd1()
i = 0 ' カウンタ初期化
Do Until rs1.EOF
' レコードの年、月、日
myYear1(0) = Year(rs1!日付)
myMonth1(0) = Month(rs1!日付)
myDay1(0) = Day(rs1!日付)
myID1(0) = rs1!ID
' 同じ年月
If (myYear1(0) = myYear1(1)) And (myMonth1(0) = myMonth1(1)) Then
' MsgBox "i=" & i ' debug
ReDim Preserve myRcd1(4, i)
myRcd1(0, i) = rs1.AbsolutePosition ' レコード番号
myRcd1(1, i) = myDay1(0) ' 日
myRcd1(2, i) = myID1(0) ' ID
If myRcd1(0, i) = rcdNo1(2) Then
myRcd1(3, i) = 1 ' 領収書番号
If myRcd1(2, i) = myID Then
SetRyouSyuNo1 = 1
Exit Function
End If
' MsgBox "myRcd1(0, i)=" & myRcd1(0, i)
Else
myRcd1(3, i) = 0 ' 領収書番号
End If
If myID1(0) = myID Then
myRcd1(4, i) = 1 ' Flag(ID一致)
Else
myRcd1(4, i) = 0 ' Flag
End If
i = i + 1
End If
rs1.MoveNext
Loop
' レコードセットを閉じる
rs1.Close: Set rs1 = Nothing
db1.Close: Set db1 = Nothing
myDay1(2) = 32 ' 日
myID1(2) = 9999 ' ID
myRyNo1(3) = 1 ' 現在の領収書番号
For i = 0 To myCntRcd1 - 2
For j = 0 To myCntRcd1 - 1
If (myRcd1(3, j) = 0) And _
((myRcd1(1, j) < myDay1(2)) Or _
((myRcd1(1, j) = myDay1(2)) And (myRcd1(2, j) < myID1(2)))) Then
myDay1(2) = myRcd1(1, j) ' 日
myID1(2) = myRcd1(2, j) ' ID
k = j
End If
Next j
myRyNo1(3) = myRyNo1(3) + 1 ' 現在の領収書番号
myRcd1(3, k) = myRyNo1(3)
If myID = myRcd1(2, k) Then
SetRyouSyuNo1 = myRyNo1(3)
End If
' MsgBox "k=" & k & " myID1(2) =" & myID1(2) & " myRcd1(3, k) =" & myRcd1(3, k)
myDay1(2) = 32 ' 日
myID1(2) = 9999 ' ID
Next i
End Function
ヤバイぜ! ありがとうございます[__猫]
by cheese999 (2017-07-06 11:33)