更新查询以在MS Access表中的指定范围内插入缺少的日期

debugcn 发表于 Dev

罗恩·R。

我有一个Access数据库，该数据库正在跟踪工作数据的35周滚动窗口。我将其自动化，因此每月运行一次脚本，该脚本会生成一封电子邮件并为适当的程序经理附上一个Excel工作表，以便他们可以在接下来的35周内更新其机组人员数量预测。该程序将保存Excel工作表的副本，以便在工作表返回后可以进行比较。

我想做的是在构建通过电子邮件发送的Excel工作表之前，添加其数据集中缺少的日期。这样，我存储日期的表将具有一个自动生成的订单项编号，稍后当我从Excel文件中重新导入数据时可以参考该编号。

我想我可以运行一个更新查询，该查询将数据库中的所有作业记录扩展到相同的结束日期，然后随着滚动窗口的消失而清除人员计数为零的所有记录，但是有没有更好的方法接近这个？

韦恩·邓恩

以下代码将：1.添加缺少的日期（但仅在运行日期的4周内）2.在当前日期之后添加35个新的“ week”记录

此代码要求您的表设计具有Job_ID + WeekDate的唯一键

Option Compare Database
Option Explicit

Dim dbs     As DAO.Database
Dim rsJobs  As DAO.recordSet
Dim rsWeek  As DAO.recordSet

Function Create_New_Weeks()
Dim strSQL  As String
Dim i       As Integer
Dim dStartDate      As Date
Dim dEndDate        As Date
Dim dPriorMonday    As Date
Dim dTempDate       As Date
Dim strJobID        As String

Const iWksToAdd = 35            ' Change as desired

    On Error GoTo Error_Trap

    Set dbs = CurrentDb

    ' Get Job_ID and Week records for all OPEN Jobs.
    ' Expect this to possibly be the first date, possibly a gap in dates, then
    ' one or more weekly dates.
    strSQL = "SELECT tblProjects.Job_ID, tblProjects.DateEnded, tblJobWeeks.WorkWeek " & _
                "FROM tblProjects INNER JOIN tblJobWeeks ON tblProjects.Job_ID = tblJobWeeks.Job_ID " & _
                "WHERE (((tblProjects.DateEnded) Is Null)) " & _
                "ORDER BY tblProjects.Job_ID, tblJobWeeks.WorkWeek;"
    Set rsJobs = dbs.OpenRecordset(strSQL)

    If rsJobs.EOF Then
        MsgBox "No Jobs found!", vbOKOnly + vbCritical, "No Jobs"
        GoTo Exit_Code
    Else
        rsJobs.MoveFirst
    End If

    ' First, find prior Monday's date as a baseline
    dPriorMonday = DateAdd("ww", -1, Date - (Weekday(Date, vbMonday) - 1))

    ' Calculate +35 weeks -- and make sure the date will be a monday.
    If Weekday(Date, 1) = 2 Then
        dEndDate = DateAdd("ww", iWksToAdd, Date)
    Else
        dEndDate = DateAdd("ww", iWksToAdd, dPriorMonday)
    End If

    ' Open the 'Weekly' table for inserting 35 new records, plus missing dates
    strSQL = "select * from tblJobWeeks order by Job_ID, WorkWeek"
    Set rsWeek = dbs.OpenRecordset(strSQL)

    ' FYI: It doesn't make sense to add records between the 'start' date and + 35 weeks, then
    ' have your monthly process delete empty ones from prior months.
    ' This code will only add missing records going back 4 weeks.

    ' Your notes indicated there would be at least two records for any given Job. If that is
    ' not correct, this code may not work!

    ' Save the starting point
    strJobID = rsJobs!Job_ID
    dTempDate = rsJobs!WorkWeek
    Do While Not rsJobs.EOF
        Debug.Print "Job: " & rsJobs!Job_ID & vbTab & "First Date: " & rsJobs!WorkWeek & vbTab & "W/E: " & rsJobs!WorkWeek
        If strJobID <> rsJobs!Job_ID Then   ' We have changed to a NEW Job_ID
            ' Fill the +35 weeks
            ' Only add prior 4 wks , then +35
            If dTempDate < dEndDate Then dTempDate = DateAdd("ww", -3, dPriorMonday)    ' Get date from 3 or 4 weeks back.
            Do
                If dTempDate < dEndDate Then
                    ' Don't add dates over 4 weeks old - Remove this if necessary
                    If dTempDate >= DateAdd("ww", -4, Date) Then
                        Debug.Print "Insert ID: " & strJobID & vbTab & dTempDate
                        Add_Week strJobID, dTempDate
                    Else
                        Debug.Print "Skip - Older than 4 weeks: " & vbTab & dTempDate
                    End If
                    dTempDate = DateAdd("ww", 1, dTempDate)
                Else
                    Exit Do
                End If
            Loop
            strJobID = rsJobs!Job_ID
            dTempDate = DateAdd("ww", 1, rsJobs!WorkWeek)       ' Should be the FIRST date for this Job
        Else
            If rsJobs!WorkWeek = dTempDate Then
                dTempDate = DateAdd("ww", 1, dTempDate)
            Else
                ' Don't add dates over 4 weeks old - Remove this if necessary
                If dTempDate > DateAdd("ww", -4, Date) Then
                    Debug.Print "Insert ID: " & strJobID & vbTab & dTempDate
                    Add_Week strJobID, dTempDate
                Else
                    Debug.Print "Skip - Older than 4 weeks: " & vbTab & dTempDate
                End If
                dTempDate = DateAdd("ww", 1, dTempDate)
            End If
        End If
        rsJobs.MoveNext
    Loop

    'Check if last ID has +35 dates
    If dTempDate < dEndDate Then
        Do Until dEndDate = dTempDate
            ' Don't add dates over 4 weeks old - Remove this if necessary
            If dTempDate > DateAdd("ww", -4, Date) Then
                Debug.Print "Insert ID: " & strJobID & vbTab & dTempDate
                Add_Week strJobID, dTempDate
            Else
                Debug.Print "Skip - Older than 4 weeks: " & vbTab & dTempDate
            End If
            dTempDate = DateAdd("ww", 1, dTempDate)
        Loop
    End If

Exit_Code:
    If Not rsJobs Is Nothing Then
        rsJobs.Close
        Set rsJobs = Nothing
    End If
    If Not rsWeek Is Nothing Then
        rsWeek.Close
        Set rsWeek = Nothing
    End If
    dbs.Close
    Set dbs = Nothing
    Exit Function
Error_Trap:
    Debug.Print Err.Number & vbTab & Err.Description & vbCrLf & "In:       Create_New_Weeks"
    ' If duplicate record, ignore
    If Err.Number = 3022 Then
        Resume Next
    End If
    MsgBox Err.Number & vbTab & Err.Description & vbCrLf & "In: Create_New_Weeks"
    Create_New_Weeks = "Error: " & Err.Number & vbTab & Err.Description & vbCrLf & "In: Create_New_Weeks"
    Resume Exit_Code
    Resume
End Function

Function Add_Week(strID As String, dDate As Date)
    With rsWeek
        .AddNew
        !Job_ID = strID
        !WorkWeek = dDate
        !Crew_Num = 0
        .Update
    End With

End Function

本文收集自互联网，转载请注明来源。

如有侵权，请联系[email protected] 删除。