VBA - Count Values within a certain Date Range - vba

Question

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

Answer 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.