更新查询以在MS Access表中指定的范围内插入缺less的date
我有一个Access数据库跟踪滚动35周窗口的作业数据。 我有它自动化，所以一个月一次我运行一个脚本，生成一个电子邮件，并附加一个Excel工作表为适当的程序pipe理器，使他们可以更新他们的船员数量预测未来35周。 该程序保存了Excel工作表的一个副本，以便在工作表返回后可以运行比较。
我想要做的是在构build通过电子邮件发送的Excel工作表之前，从其数据集中添加缺失的date。 这样，我存储date的表格就会有一个自动生成的订单项编号，稍后我可以从Excel文件重新导入数据时参考。
我想我可以运行一个更新查询，将数据库中的所有工作logging展开到相同的结束date，并随后在滚动窗口消失时清除任何有零个工作人员数的东西，但有没有更好的方法接近这个？
下面的代码将会：1.添加缺失的date（但是只在运行date的4周内）2.添加35个新的“星期”logging以超过当前date
此代码要求您的表格devise具有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