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 ，并且代码将“选择”日期比该特定日期最接近(但更小)的行。