MS ACCESS 中的 VBA 调度算法

Posted 2023-04-19

【中文标题】MS ACCESS 中的 VBA 调度算法

【英文标题】：VBA Scheduling Algorithm in MS ACCESS

【发布时间】：2018-07-05 06:28:09

【问题描述】：

我想根据给定日期计算一些时间表。像我一样

开始日期 结束日期 工作日，例如，星期一、星期三作为频率

我需要计算 weekly biweekly triweekly monthly quarterly 日期从开始日期和结束日期开始，也通过匹配给定的工作日。

举个例子

Date start = 05/07/2018
Date End = 15/07/2018
Frequency days = Saturday

我需要每周星期六的日期，然后是每两周的星期六日期，直到它到达结束日期。

我在 MS ACCESS VBA 中尝试了 DAYOFWEEK，这有点帮助，但我需要知道完整的解决方案，以便计算时间表。

感谢您的帮助。

谢谢

【问题讨论】：

您正在寻找DateAdd 函数。

@Andre 你知道的越多...DateAdd 似乎相当强大，实际上。另外，这不是一个完整的答案吗？

我猜你是对的。 :) @Inarion

【参考方案1】：

DateAdd Function 可以做到所有这些。

航空代码：

d = StartDate
Do While d <= EndDate
    Debug.Print d   ' <-- Output date
    Select Case Interval
        Case "biweekly": d = DateAdd("ww", 2, d)
        Case "monthly" : d = DateAdd("m", 1, d)
        ' etc.
    End Select
Loop

【讨论】：

谢谢。 DateAdd 看起来很有希望。但是我如何才能在 2 周后获得特定日期的日期，例如星期五。例如。 2 周、3 周、4 周等后的星期五日期是什么

@Aziz，我附加了一个查找工作日日期的函数。

【参考方案2】：

对于月份，您应始终添加到原始开始日期，因为这可能是一个月的最后几天之一，因此会抵消月份较少天数之后的月份的日期。所以：

Dim StartDate   As Date
Dim EndDate     As Date
Dim NextDate    As Date
Dim Interval    As Long

StartDate = #1/31/2018#
EndDate = #6/30/2018#

Do
    NextDate = DateAdd("m", Interval, StartDate)
    Interval = Interval + 1
    Debug.Print NextDate
Loop Until NextDate >= EndDate

将返回：

2018-01-31
2018-02-28
2018-03-31
2018-04-30
2018-05-31
2018-06-30

对于从特定工作日开始，找到第一个，然后按上述添加间隔：

Public Function DateNextWeekday( _
  ByVal datDate As Date, _
  Optional ByVal bytWeekday As Byte = vbMonday) _
  As Date

' Returns the date of the next weekday, as spelled in vbXxxxday, following datDate.
' 2000-09-06. Cactus Data ApS.

  ' No special error handling.
  On Error Resume Next

  DateNextWeekday = DateAdd("d", 7 - (Weekday(datDate, bytWeekday) - 1), datDate)

End Function

【参考方案3】：

这也应该可以 - 我已经包含输入框，因此您可以输入开始日期、完成日期、星期几和频率，因为我不知道您希望如何输入；这也会将值存储在 Table2 中，它有一个名为 Dates 的字段/列，然后你可以检索它们（我不知道你想如何检索日期，如果你想存储它们等）.. .我希望这会有所帮助！：

Sub test()

'clear the table2:
CurrentDb.Execute "DELETE * FROM Table2"

Dim DBTest As String
Dim RSTest As DAO.Recordset
Dim i As Long
Dim selectorInitDate, selectorEndDate, DBDate As Date

'Enter Start Date
selectorInitDate = Format(InputBox("Initial Date"), "mm/dd/yyyy")
'Enter Finish Date
selectorEndDate = Format(InputBox("End Date"), "mm/dd/yyyy")
'Enter Day of the Week (example: Saturday)
selectorWeekDay = InputBox("Week Day")
'Enter Frecuency (example: weekly, biweekly, etc)
selectorFreqDays = InputBox("Frecuency Days")

If selectorWeekDay = "Sunday" Then WeekDaySelected = 1
If selectorWeekDay = "Monday" Then WeekDaySelected = 2
If selectorWeekDay = "Tuesday" Then WeekDaySelected = 3
If selectorWeekDay = "Wednesday" Then WeekDaySelected = 4
If selectorWeekDay = "Thursday" Then WeekDaySelected = 5
If selectorWeekDay = "Friday" Then WeekDaySelected = 6
If selectorWeekDay = "Saturday" Then WeekDaySelected = 7

If selectorFreqDays = "weekly" Then Freq = 7
If selectorFreqDays = "biweekly" Then Freq = 14
If selectorFreqDays = "triweekly" Then Freq = 21
If selectorFreqDays = "monthly" Then Freq = 30
If selectorFreqDays = "quarterly" Then Freq = 90


DBDate = Format(selectorInitDate, "mm/dd/yyyy")
Count = 0

Do While DBDate <= selectorEndDate

    If Weekday(DBDate) = WeekDaySelected Then

        DBTest = "INSERT INTO Table2 ([Dates]) " & _
                    " VALUES (" & _
                    "'" & DBDate & "');"

        CurrentDb.Execute DBTest

        DBDate = DBDate + Freq - 1

        Count = Count + 1

    End If

DBDate = DBDate + 1

Loop

'this retrieves in a msgbox the saturdays found between the two dates you specify:

DBTest = "SELECT * FROM Table2"

Set RSTest = CurrentDb.OpenRecordset(DBTest)

If Not RSTest.BOF And Not RSTest.EOF Then

    RSTest.MoveFirst

    Do While (Not RSTest.EOF)

        If Format(RSTest.Fields("Dates").Value, "mm/dd/yyyy") >= selectorInitDate And _
        Format(RSTest.Fields("Dates").Value, "mm/dd/yyyy") <= selectorEndDate Then

            mthString = mthString & RSTest.Fields("Dates") & ", "

        End If

      RSTest.MoveNext

     Loop

   End If

' (remove last comma)
mthString = Left(mthString, Len(mthString) - 2)

MsgBox Count & " " & selectorWeekDay & "(s) Added" & Chr(43) & mthString

'clear the table2:
CurrentDb.Execute "DELETE * FROM Table2"

End Sub

按照您的示例，这应该会告诉您每周两个日期之间有多少个星期六，以及这些日期。

注意：您需要在参考中选择“Microsoft DAO 3.6 对象库”

【讨论】：

太棒了。非常感谢。仅 2 cmets 1. 如果我们有多个工作日，例如星期五|星期六，用管道符号分隔 2. 如何选择引用我正在使用 MS Access 2016 的“Microsoft DAO 3.6 对象库”。

1.您可以使用管道符号从字符串中提取“星期五”和“星期六”，然后运行宏； 2. 在 Visual Basic 编辑器中，您必须选择 Tools > References... > Microsoft DAO 3.6 Object Library - :)

非常感谢。您的解决方案效果很好。有一个问题。假设我选择了本周的星期六，并希望获得下周星期一的日期。你知道下周将在一天后开始。但是在您的解决方案中，您要添加 7、14、21 等等。它将日期带到未来，我们无法获得过去的那一周特定日期。我希望你明白我想说什么。

在第一次查找后添加7,14等，所以如果输入7/7/2018是星期六，然后选择星期一，它应该检索下星期一是7/9/ 2018.

是的，这是错误的。它应该检索当前的星期一。

【参考方案4】：

如果您只想将双周日期以 14 天为增量分组，从某个开始日期（例如一年中的第一周）开始，indate 可以是当前日期或您选择的某个日期，或者您可以只是今天（） .

Function biweeklyDate(indate as date) as Date
biweeklyDate = (DateSerial(2021,1,4)-indate) Mod 14 + inDate
End function