代码之家 › 专栏 › 技术社区 › Krono

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

vba excel

Krono · 技术社区 · 4 年前

我有一些基于估计的资源数据,显示了分配给任务的每个“角色”每月的工作时间。

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

即,在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月等在开始/结束日期之间发生的次数?

0 回复 | 直到 4 年前

FaneDuru 4 年前

请测试下一个代码。它将返回正确的周数、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

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

firstWeekDay 需要常数。如果“02-Oct-21”是周一的周日,则返回周数的函数可能会以加号或减号返回一周(以周日结束)。对于你(现在)需要的范围来说,这并不重要,但如果你改变了相关日期, 这可能很重要 ,以获得准确的回报。。。

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

Skin 4 年前

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

添加对的引用 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

我已经假设开始日期总是正确的,我不会检查它是否如你所描述的那样。这对我来说似乎太夸张了。