【Access】自作自演で課題をやってみる3

前回の続き。

SQL文が出来たのでそれを使ってVBAを組んでみます。個人的な趣味で変数の使い回しやレコードセットの使い回しは禁止してますので若干長くなりがちですが気にしません。

'targetDate = 抽出日
Sub ChoiceEmployee(targetDate As Date)

'選出人数管理用
Dim choiceNum As Integer
choiceNum = 0

Dim cn As ADODB.Connection
Set cn = CurrentProject.Connection

'最初の選出SQL文
Dim selectSql1 As String
selectSql1 = "SELECT TOP 5 * FROM Employees WHERE ChoseDate = #9999/12/31# ORDER BY Rnd([Id])"

Dim rs1 As ADODB.Recordset
Set rs1 = New ADODB.Recordset
rs1.Open selectSql1, cn, adOpenKeyset, adLockOptimistic

'もしレコードが0件なら1巡してるので初期化
If rs1.RecordCount = 0 Then
Dim updateSql1 As String
updateSql1 = "UPDATE Employees SET ChoseDate = #9999/12/31#"
cn.Execute updateSql1
Else
Do Until rs1.EOF
'選出日をtargetDateで更新
Dim updateSql2 As String
updateSql2 = "UPDATE Employees SET ChoseDate = #" & targetDate & "# WHERE Id = " & rs1![Id]
cn.Execute updateSql2
choiceNum = choiceNum + 1
rs1.MoveNext
Loop
End If

rs1.Close
Set rs1 = Nothing

'選出人数が足りない場合
If choiceNum < 5 Then
'2回目の選出SQL文
Dim selectSql2 As String
selectSql2 = "SELECT TOP " & 5 - choiceNum & " * FROM Employees WHERE ChoseDate <= #" & DateAdd("m", -3, targetDate) & "# ORDER BY Rnd([Id])"

Dim rs2 As ADODB.Recordset
Set rs2 = New ADODB.Recordset
rs2.Open selectSql2, cn, adOpenKeyset, adLockOptimistic

Do Until rs2.EOF
'選出日をtargetDateで更新
Dim updateSql3 As String
updateSql3 = "UPDATE Employees SET ChoseDate = #" & targetDate & "# WHERE Id = " & rs2![Id]
cn.Execute updateSql3
Loop

rs2.Close
Set rs2 = Nothing
End If

cn.Close
Set cn = Nothing

End Sub

またまた個人的な趣味ですがレコードセットを直接更新かけるのが嫌いなのでUPDATEのSQL文を書いてます。別にレコードセットを直接「rs![ChoseDate] = 日付」&「rs.Update」とかやっちゃってもかまいません。

次にレポート作成の前にもう1つレポート印刷時に実行する処理をついでに組んでしまいましょう。作成条件の「毎月、月初めにその月の掃除当番表を作成し、出力する。」ってやつで「選出の実行はこれが出力されるタイミングでやっちゃえば良いでしょう」なんて考えてました。なので流れは…月を入力→各週の当番選出→印刷って感じかなぁ。

選出メソッドは出来てるので、対象月の各週毎にそれを実行すること考えます。まず基準日がいりますね。これは特に指定してませんので各週の日曜日にしちゃいます。なので対象月の全ての日曜日の日付を取得する必要があります。

'targetYear = 対象年
'targetMonth = 対象月
Function GetSunday(targetYear As Integer, targetMonth As Integer) As Date()

'その月の1日の曜日番号を取得
Dim targetWeekNum As Integer
targetWeekNum = Weekday(DateSerial(targetYear, targetMonth, 1))

'最初の日曜日を取得
Dim firstDay As Date

If 1 = targetWeekNum Then
firstDay = DateSerial(targetYear, targetMonth, 1)
Else
firstDay = DateSerial(targetYear, targetMonth, 1 - targetWeekNum + 8)
End If

Dim tempDay As Date
tempDay = firstDay

Dim result() As Date
Dim arrayNum As Integer
arrayNum = 0

'月が変わるまでループ
Do While targetMonth = Month(tempDay)
ReDim Preserve result(arrayNum)
result(arrayNum) = tempDay
tempDay = tempDay + 7
arrayNum = arrayNum + 1
Loop

GetSunday = result

End Function

こんな感じでどうでしょう。最初の日曜を求める部分の「DateSerial(targetYear, targetMonth, 1 - targetWeekNum + 8)」は分かりづらいかもしれませんが計算したらそうなったって感じです。

だいぶ完成が見えてきました。次回はフォームとレポートをちゃっちゃっと作ってしまいましょう。