DateDiff计数每个月的出现次数，在两个日期之间每周出现一次

Question

我有一些基于估计的资源数据，显示我每个"；角色；分配给任务。

我需要能够计算一个"；月份；出现在两个日期之间的每周计数中。所以我可以相应地分配时间。

即，在2021年10月2日至11月27日期间，有9周时间，从以下代码输出：

Public Sub dtConv()
Dim stDt, enDt As Date
stDt = Sheets("New Job Template").Range("F1").Value
enDt = Sheets("New Job Template").Range("H1").Value
Debug.Print (DateDiff("ww", stDt, enDt))
End Sub

给我看8周(这是错误的(。

但以上并没有告诉我；十一月"；发生5次；十二月"；发生4次。

我可以利用DateDiff来计算11月/12月/1月等在开始/结束日期之间发生的次数吗？

Answer 1

请测试下一个代码。它将返回正确的周数，10月和11月的发生次数：

Private Sub testTextEvaluateDateManyMonths()
Dim arrD, stDt As Date, enDt As Date, noD As Long, startD As Long, startM As Long, i As Long, mName As String
Dim WCount As Long, prevWNo As Long, wNo As Long, k As Long, dictM As Object
Const firstWeekDay As Long = vbMonday '(2) you should use here your first day of the week.
' for Sunday you should use vbSunday, or 1
stDt = "02-Oct-21": enDt = "28-Feb-22"
noD = enDt - stDt + 1      ' number of involved days between the two date
startM = month(stDt)       ' month number in stDt
startD = Day(stDt)         ' day number in stDt
'create an array of involved dates:
'arrD = Application.Transpose(Evaluate("TEXT(DATE(2021," & startM & ",row(" & startD & ":" & noD + 1 & ")),""dd.mm.yyyy"")"))
arrD = Evaluate("TEXT(DATE(2021," & startM & ",row(" & startD & ":" & noD + 1 & ")),""dd.mm.yyyy"")")
ReDim arrMonths(DateDiff("m", stDt, enDt, vbMonday))
Debug.Print Join(Application.Transpose(arrD), "|") 'just to see the date range in Immediate Window...
Set dictM = CreateObject("Scripting.Dictionary")
For i = 1 To UBound(arrD)
wNo = WorksheetFunction.WeekNum(CDate(arrD(i, 1)), firstWeekDay)
If wNo <> prevWNo Then prevWNo = wNo: WCount = WCount + 1
mName = Format(CDate(arrD(i, 1)), "mmmm")
dictM(mName) = dictM(mName) + 1
Next i
For i = 0 To dictM.Count - 1
Debug.Print "Month " & dictM.Keys()(i) & " appears " & dictM.items()(i) & " times."
Next i
Debug.Print "Weeks number: " & WCount
End Sub

上面的代码构建了一个必要天数范围的数组，并非常快速地(在内存中(分析它，提取出您需要的内容(我理解(。

需要CCD_ 1常数。如果"；02-Oct-21"；返回周数的函数可能会返回一周(以周日结束(的加号或减号。对于您(现在(需要的范围，这并不重要，但如果您更改所涉及的日期，这可能很重要，以获得准确的回报。。。

如果有不清楚的地方或其他需要从天数范围中提取的东西，请毫不犹豫地要求澄清。

Answer 2

不确定这是否是你想要的，但看看你如何根据需要进行调整。能做得更好吗？！？大概

在项目中添加对Scripting.Dictionary的引用，并将日期分别放在A1(起始日期(和A2(截止日期(中。

Public Sub CountMonthsInWeeks()
Dim objValues As Scripting.Dictionary
Dim dtFrom As Date, dtTo As Date, bDone As Boolean
Dim dtFromTemp As Date, dtToTemp As Date, intMonth As Integer
Dim strKey As Variant, strMonth As String

Set objValues = New Scripting.Dictionary

dtFrom = CDate(Sheet1.Range("A1").Value)
dtTo = CDate(Sheet1.Range("A2").Value) - 1

dtFromTemp = dtFrom

Do While Not bDone
dtToTemp = dtFromTemp + 6

Debug.Print "From = " & dtFromTemp & ", To = " & dtToTemp

If dtToTemp >= dtTo Then
dtToTemp = dtTo
bDone = True
End If

UpdateMonthCount objValues, Month(dtFromTemp)
If Month(dtToTemp) <> Month(dtFromTemp) Then UpdateMonthCount objValues, Month(dtToTemp)

dtFromTemp = dtToTemp + 1
Loop

Debug.Print ""

For Each strKey In objValues.Keys
strMonth = WorksheetFunction.Text(DateSerial(Year(Now), strKey, 1), "mmm")
Debug.Print "Month " & strMonth & " = " & objValues.Item(strKey)
Next
End Sub
Private Sub UpdateMonthCount(ByRef objValues As Scripting.Dictionary, ByVal intMonth As Integer)
If Not objValues.Exists(intMonth) Then objValues.Add intMonth, 0
objValues.Item(intMonth) = objValues.Item(intMonth) + 1
End Sub

我已经假设开始日期永远是正确的一天，我不会检查它是否如你所描述的那样。这对我来说似乎有些过头了。