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 months。如果计算，颜色灰色有3个数据只会返回2个月，因为一个月内有2个数据。棕色符合标准，因为只要每个月（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重复值的数据就可以了。

现在这里是我的代码：

Timer

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

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

请注意，我不确定您希望选择哪个日期＆＃34;已选择＆＃34;日期。因此，我添加了变量CloseToDate，代码将＆＃34;选择＆＃34;日期最接近（但小于）特定日期的行。

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

1 个答案: