用日期做While循环

问题描述

我正在VBA中编写代码，该代码可以遍历日期并将某些数据添加到Access中的某些表。我觉得我已经尝试了一切并浏览了网络，但似乎仍然无法正常工作。我认为我的问题是日期格式，因为我使用的是欧洲日期输入，而不是美国输入。我试图格式化日期，如下面的代码所示。

Dim TODAY as string,TimeReg as string,UserReg as string,Init as string,_ 
SendFrom as string,SendTo as string,DateFrom as Date,DateTo as date,_
Comment as string

'Me.txtDateF.value Input f.ex. = 01-01-2020
'Me.txtDateT.value Input f.ex. = 16-01-2020

'Values'
TODAY = Me.txtDD.Value
TimeReg = Me.txtTime.value
UserReg = Left(Me.txtUser.value,3)
Init = Me.cmbInit.value
If IsNull(Me.txtFrom.value) Then
SendFrom = ""
Else
SendFrom = Me.txtFra.value
End if

SendTo = Me.cmbTo.Column(1)
DateFrom = CDate(Format(Me.txtDateF.value,"dd-mm-yyyy"))
DateTo = CDate(Format(Me.txtDateT.value,"dd-mm-yyyy"))
Comment = Me.txtComment.value

'Define team on which it will use in SQL-Query
Select Case Me.txtTeam.value
Case "Team 1"
Team = "Team1"
TeamCom = "Team1Com"
Case "Team 2" etc...
End select

DoCmd.SetWarnings False

Do While DateFrom < DateTo

strSQL = "UPDATE [" & Team & "] SET [" & Init & "] = '" & SendTo & "' WHERE Date = #" & DateFrom "#"

DoCmd.RunSQL strSQL

ChangeSQL = "INSERT INTO tblChanges " _
& "(Date,Time,InitChange,TimeR,ShiftB,ShiftA,DateR,DateT,Comment)" _
& "VALUES (#" & TODAY & "#,#" & TimeReg & "#,'" & Init & "','" & UserReg & "','" & SendFrom & "','" & SendTo & "',#" & DateFrom "# '" & Comment & "');"

DoCmd.RunSQL ChangeSQL

DateFrom = DateAdd("d",1,DateFrom)
Loop

DoCmd.SetWarnings True

如果输入日期来自f.ex。 2020年1月1日至2020年1月24日，以下日期会更改。

• 01-01-2020
• 2020年1月13日
• 2020年1月14日
• 2020年1月15日
• 2020年1月16日
• 2020年1月17日
• 18-01-2020
• 19-01-2020
• 20-01-2020
• 2020年1月21日
• 2020年1月22日
• 2020年1月23日
• 24-01-2020
• 01-02-2020
• 01-03-2020

缺少日期为01-01-2020到12-01-2020的日期。在我看来，格式已关闭。

解决方法

这里有很多错误，但这应该使您更接近：

Dim Today As Date,TimeReg As Date,UserReg As String,Init As String,_ 
SendFrom As string,SendTo As String,DateFrom As Date,DateTo As Date,_
Comment As String

'Me.txtDateF.value Input f.ex. = 01-01-2020
'Me.txtDateT.value Input f.ex. = 16-01-2020

'Values'
Today = TimeValue(Me!txtDD.Value)
TimeReg = Me!txtTime.Value
UserReg = Left(Me!txtUser.Value,3)
Init = Me!cmbInit.Value
If IsNull(Me!txtFrom.Value) Then
    SendFrom = ""
Else
    SendFrom = Me!txtFra.Value
End if

SendTo = Me!cmbTo.Column(1)
DateFrom = DateValue(Me!txtDateF.Value)
DateTo = DateValue(Me!txtDateT.Value)
Comment = Me!txtComment.Value

'Define team on which it will use in SQL-Query
Select Case Me!txtTeam.Value
    Case "Team 1"
        Team = "Team1"
        TeamCom = "Team1Com"
    Case "Team 2" etc...
End select

DoCmd.SetWarnings False

Do While DateFrom < DateTo

    strSQL = "UPDATE [" & Team & "] SET [" & Init & "] = '" & SendTo & "' WHERE [Date] = #" & Format(DateFrom,"yyyy\/mm\/dd") & "#"
    DoCmd.RunSQL strSQL

    ' Correct here. Range of fields doesn't match range of values!
    ChangeSQL = "INSERT INTO tblChanges " & _
        "([Date],[Time],InitChange,TimeR,ShiftB,ShiftA,DateR,DateT,Comment)" & _
        "VALUES (#" & Format(Today,"yyyy\/mm\/dd") & "#,#" & Format(TimeReg,"hh\:nn\:ss") & "#,'" & Init & "','" & UserReg & "','" & SendFrom & "','" & SendTo & "',#" & Format(DateFrom,#" & Format(DateTo,'" & Comment & "');"
    DoCmd.RunSQL ChangeSQL

    DateFrom = DateAdd("d",1,DateFrom)
Loop

DoCmd.SetWarnings True

或者使用我的函数CSql重写/简化SQL。

,

我是如何解决的： 首先，我设置值

 Date0 = DateAdd("d",CDate(Format(Me.txtDateF.value,"dd/mm/yyyy")))

然后，在sql语句中，我会这样写

 strSQL = "UPDATE [" & Team & "] SET [" & Init & "] = '" & SendTo & "' WHERE Date = #" & Format(Date0,"yyyy/mm/dd") & "# "

希望有帮助。事实是访问中的日期在开始时也使我感到困惑！

,

使用帮助程序函数创建SQL语句，可以独立于其余代码测试查询。

DateValue()

使用助手功能，我可以将SQL语句打印到立即窗口。然后，我将使用访问查询设计器来测试SQL。

使用Function mySum(rngDB As Range) Dim mCol As Object 'MatchCollection Dim Ws As Worksheet Dim rng As Range Dim strPattern As String Dim s As String Dim i As Integer,n As Integer Dim vSum() As Variant Application.Volatile Set Ws = ActiveSheet strPattern = "(()([0-9]{1,})())" For Each rng In rngDB s = rng.Value Set mCol = GetRegEx(s,strPattern) If Not mCol Is Nothing Then For i = 0 To mCol.Count - 1 n = n + 1 ReDim Preserve vSum(1 To n) vSum(n) = Val(mCol.Item(i)) Next i End If Next If n Then mySum = WorksheetFunction.Sum(vSum) End If End Function Function GetRegEx(StrInput As String,strPattern As String) As Object Dim RegEx As Object 'New RegExp Set RegEx = CreateObject("VBScript.RegExp") With RegEx .Global = True .IgnoreCase = False .MultiLine = True .Pattern = strPattern End With If RegEx.test(StrInput) Then Set GetRegEx = RegEx.Execute(StrInput) End If End Function 从“日期”字段中删除时间值。

WHERE DateValue（[Date]）=＃“＆DateFrom”＃“