VBA - Count Values within a certain Date Range

问题

First, Let me tell you the script that i want to achieve. I need a script that will count the values within a date range the range of date is 3 months, I have a source file which contains 3 months of data now i need to count the data by months if the data is within the months(3) tagged it as selected..(at least one value per month(up to 3))

Sample:

`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 |        |

Sample Output:

`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|

In the sample above. The data white has been tagged as selected because it meets the required criteria, let's say the criteria needed is "at least one color per month" we have 3 month of data so it needs to count 1 color per month. The other color in the ex. didnt meet the criteria like the color black it only have data for 2 months what we need is for 3 months. The color grey have 3 data if you count it will only return 2 months because there is 2 data in a month. The color brown meets the criteria because there is a data for 3 months duplicate value in a month is fine as long it has a data every months(3) for..

Now here's my code:

'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

please help me about this....

回答1:

Formula Solution
Although I acknowledge that you are looking for a VBA solution to this (perhapse for a good reason), I want to point out that you can solve this by using formulas. You could get the result you are looking for by using an array formula like:

{=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","")}

This will return Selected if the color is found in at least three different months.

To use this, type the formula in cell C2, commit by pressing CTRL+SHIFT+ENTER (since it is an array formula) and drag the formula down along side of your data.

VBA+Formula Solution
As you commented that you need this applied in a generated report, you could simply use VBA to type the formula into the sheet:

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-Only Solution
While completely disregarding your original code, you may be able to get inspired by this take on a VBA-only solution

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

Note, that I am unsure about exactly which date you want to be the "selected" date. Thus, I have added the variable CloseToDate, and the code will "select" the row with the date that is closest (but smaller) than this particular date.

来源：https://stackoverflow.com/questions/36125280/vba-count-values-within-a-certain-date-range

标签

vba

excel-vba

excel