VBA - 计算特定日期范围内的值

Question

首先，让我告诉你我想要实现的脚本。我需要一个脚本来计算日期范围内的值，日期范围是 3 个月，我有一个包含 3 个月数据的源文件，如果数据在几个月内，我需要按月计算数据（3 ) 将其标记为选中..（每月至少一个值（最多 3 个））

示例：

`Header A|Header B  |Header C|
   white | 1/1/2016 |        |
   white | 2/2/2016 |        |
   white | 3/3/2016 |        |
   black | 1/1/2016 |        |
   black | 2/2/2016 |        |
   grey  | 3/3/2016 |        |
   grey  | 3/3/2016 |        |
   grey  | 4/4/2016 |        |
   brown | 4/4/2016 |        |
   brown | 4/4/2016 |        |
   brown | 5/5/2016 |        |
   brown | 6/6/2016 |        |

样本输出：

`Header A|Header B  |Header C|
   white | 1/1/2016 |        |
   white | 2/2/2016 |        |
   white | 3/3/2016 |selected|
   black | 1/1/2016 |        |
   black | 2/2/2016 |        |
   grey  | 3/3/2016 |        |
   grey  | 3/3/2016 |        |
   grey  | 4/4/2016 |        |
   brown | 4/4/2016 |        |
   brown | 4/4/2016 |        |
   brown | 5/5/2016 |        |
   brown | 6/6/2016 |selected|

在上面的示例中。数据white 已被标记为selected，因为它符合要求的标准，假设需要的标准是"at least one color per month"，我们有3 个月的数据，所以它需要每月计算1 种颜色。前任中的另一种颜色。不符合颜色black 等标准，它只有2 months 的数据，我们需要的是3 months。灰色有 3 个数据，如果计算它只会返回 2 个月，因为一个月有 2 个数据。棕色符合标准，因为每月有一个 3 months 重复值的数据就可以了，只要它每个月有一个数据(3) 就可以了..

现在这是我的代码：

'iterate all rows for 3 months to check their dates then create an arbitrary column(lastcolumn +1) to store the month value
For rownum = 2 To lastrow_masterfile

     varDatesValue = masterfileWKsht.Range("B" & rownum).Value
     masterfileWKsht.Range("D" & rownum).Value = Month(varDatesValue)

Next


'column range for color
Set myRangeColor = ThisWorkbook.Sheets("masterfile").Range("A2:A" & lastrow_masterfile)

'column range for (arbitrary column)monthvalue
Set myRangeMonthValue = ThisWorkbook.Sheets("masterfile").Range("D2:D" & lastrow_masterfile)


'loop for weekly data
For rownum_weekly = startingrow_of_weekly To lastRow
    varColors = masterfileWKsht.Range("B" & rownum_weekly).Value
    varCOMMonth = Month(masterfileWKsht.Range("A" & rownum_weekly).Value)

'CountIfs 1:
    varMonth1 = WorksheetFunction.CountIfs(myRangeColor, varColor, myRangeMonthValue, varDatesValue)

'CountIfs 2:
   'month value of varDates per row -1 for previous month(range of this is the new column which store the monthvalue)
    varMonth2 = WorksheetFunction.CountIfs(myRangeColor, varColor, myRangeMonthValue, varDatesValue - 1)


'CountIfs 3:
  'month value of varDates per row -2 for 2months ago(range of this is the new column which store the monthvalue)
    varMOnth3 = WorksheetFunction.CountIfs(myRangeColor, varColor, myRangeMonthValue, varDatesValue - 2)


    'if value of the 3 countifs is atleast 1 then tagged it as selected
    If varMonth1 >= 1 And varMonth2 >= 1 And varMOnth3 >= 1 Then
         'insert code here(i still dont khow how to write code here)
    End If

Next

请帮我解决这个问题....

Answer 1

公式解决方案
尽管我承认您正在寻找 VBA 解决方案（也许是有充分理由的），但我想指出您可以通过使用公式来解决这个问题。您可以使用如下数组公式获得所需的结果：

{=IF(SUM(IF(FREQUENCY(($A$2:$A$13=A2)*(MONTH($B$2:$B$13)),($A$2:$A$13=A2)*(MONTH($B$2:$B$13)))>0,1))>3,"Selected","")}

如果在至少三个不同的月份中找到颜色，这将返回 Selected。

要使用它，请在单元格 C2 中输入公式，按 CTRL+SHIFT+ENTER 提交（因为它是数组公式）并将公式沿着数据的一侧向下拖动。

VBA+公式解决方案
正如您评论说您需要在生成的报告中应用它，您可以简单地使用 VBA 将公式输入到工作表中：

Sub AddFormula()
    Dim MstrSht As Worksheet
    Dim ColorRng As Range
    Dim DateRng As Range
    Dim i As Integer

    Set MstrSht = ThisWorkbook.Sheets("masterfile")

    'Set Color Range and Date Range
    Set ColorRng = MstrSht.Range("A2:A" & MstrSht.Cells(Rows.Count, 1).End(xlUp).Row)
    Set DateRng = MstrSht.Range("B2:B" & MstrSht.Cells(Rows.Count, 1).End(xlUp).Row)

    'Add Formula to cells in column C
    For i = 2 To MstrSht.Cells(Rows.Count, 1).End(xlUp).Row
        MstrSht.Cells(i, 3).FormulaArray = "=IF(SUM(IF(FREQUENCY((" & ColorRng.Address & "=A" & i & " )*(MONTH(" & DateRng.Address & ")),(" & _
            ColorRng.Address & "=A" & i & ")*(MONTH(" & DateRng.Address & ")))>0,1))>3,""Selected"","""")"
    Next i
End Sub

仅 VBA 的解决方案
虽然完全无视您的原始代码，但您可能会从这种仅使用 VBA 的解决方案中获得启发

Sub MarkColors()
    Dim MstrSht As Worksheet
    Dim DataArr As Variant
    Dim ColorArr As Variant
    Dim MonthCol As Collection
    Dim CloseToDate As Date
    Dim MaxDate As Date
    Dim c As Long
    Dim i As Long

    Set MstrSht = ThisWorkbook.Sheets("masterfile")

    'Define date
    CloseToDate = DateSerial(2016, 6, 6) '<~~ Define date

    'Load Data into Array
    DataArr = MstrSht.Range("A2:C" & MstrSht.Cells(Rows.Count, 1).End(xlUp).Row)

    'Find distinct colors
    ColorArr = ReturnDistinct(MstrSht.Range("A2:A" & MstrSht.Cells(Rows.Count, 1).End(xlUp).Row))

    'Remove any values in the arrays third column
    For i = LBound(DataArr, 1) To UBound(DataArr, 1)
        DataArr(i, 3) = ""
    Next i

    'Loop Each Color
    For c = LBound(ColorArr) To UBound(ColorArr)
        Set MonthCol = New Collection
        MaxDate = 0
        For i = LBound(DataArr, 1) To UBound(DataArr, 1)
            If DataArr(i, 1) = ColorArr(c) Then
                'Load the colors months into a collection
                On Error Resume Next
                MonthCol.Add Month(DataArr(i, 2)), CStr(Month(DataArr(i, 2)))
                On Error GoTo 0
                'Find Max Date
                If DataArr(i, 2) <= CloseToDate Then
                    MaxDate = Application.WorksheetFunction.Max(MaxDate, DataArr(i, 2))
                End If
            End If
        Next i

        'If the color were found in three or more seperate months then the row with date closest to CloseToDate gets flagged
        If MonthCol.Count > 2 Then
            For i = LBound(DataArr, 1) To UBound(DataArr, 1)
                If DataArr(i, 1) = ColorArr(c) And DataArr(i, 2) = MaxDate Then
                    DataArr(i, 3) = "Selected"
                End If
            Next i
        End If
    Next c

    'Print results to sheet
    MstrSht.Range("A2:C" & MstrSht.Cells(Rows.Count, 1).End(xlUp).Row) = DataArr
End Sub

'Return Array With Distinct Values
Function ReturnDistinct(InpRng As Range) As Variant
    Dim Cell As Range
    Dim i As Integer
    Dim DistCol As New Collection
    Dim DistArr()

    'Add all values to collection
    For Each Cell In InpRng
        On Error Resume Next
        DistCol.Add Cell.Value, CStr(Cell.Value)
        On Error GoTo 0
    Next Cell

    'Write collection to array
    ReDim DistArr(1 To DistCol.Count)
    For i = 1 To DistCol.Count Step 1
        DistArr(i) = DistCol.Item(i)
    Next i

    ReturnDistinct = DistArr
End Function

请注意，我不确定您希望哪个日期成为“选定”日期。因此，我添加了变量CloseToDate，代码将“选择”日期最接近（但更小）的行。