I have a table that is populated using a CountIfs formula. I would like to code this process into VBA without having to write each cell’s formula. I can use WorksheetFunction.CountIfs to automate individual results, but I haven’t been able to code this into a loop. I would like the function to reference the variable in column A (Associate) as well as the Dates in Row 2.
Here is the table I am attempting to populate, it is defined in the workbook as “TC_Month”:
Here is the section of code I have so far:
`Sub ConstData()
Dim wb As Workbook
Set wb = ThisWorkbook
Dim BD As Worksheet
Set BD = wb.Sheets("BuiltData")
Dim YD As Worksheet
Set YD = wb.Sheets("YearData")
Dim MD As Worksheet
Set MD = wb.Sheets("MonthData")
MD.Activate
Dim CurrentMonth As Date
CurrentMonth = DateSerial(Year(Date), Month(Date), 1)
Dim wk1 As Date
wk1 = CurrentMonth
Dim wk2 As Date
wk2 = DateAdd("d", 7, wk1)
Dim wk3 As Date
wk3 = DateAdd("d", 14, wk1)
Dim wk4 As Date
wk4 = DateAdd("d", 21, wk1)
Dim wk5 As Date
wk5 = DateAdd("d", 28, wk1)
With MD.Range("TC_Month")
.Cells(2, 2).Value2 = wk1
.Cells(2, 3).Value2 = wk2
.Cells(2. 4).Value2 = wk3
.Cells(2, 5).Value2 = wk4
.Cells(2, 6).Value2 = wk5
End With
With MD.Range("TC_Month")
Dim i As Integer
i = 3
Do Until i = 7
.Cells(i, 2).Value2 = WorksheetFunction.CountIfs(BD.Range("AF:AF"), _
MD.Range("TC_Month").Cells(i, 1), BD.Range("R:R"), ">250", _
BD.Range("AK:AK"), ">=" & CLng(wk1), BD.Range("AK:AK"), _
"<" & CLng(wk2))
i = i + 1
Loop
End With`
If I use the actual cell references, this function works. When using the Integer and Loop this code results in Excel freezing or an error. It also is only setup for the first column of the table, I haven’t been able to wrap my head around how the dates could be variable as well and the additional columns calculated.
If possible, I would appreciate help in adapting this code and function to work for an entire table. I could code each individual cell function, but that wouldn’t make for very clean code.
Thank you for your time!
4
Replacing the Do Loop with a For Loop simplifies the logic and is less prone to crashing.
Dim r As Long
For r = 3 To 7
.Cells(r, 2).Value2 = WorksheetFunction.CountIfs(BD.Range("AF:AF"), _
MD.Range("TC_Month").Cells(r, 1), BD.Range("R:R"), ">250", _
BD.Range("AK:AK"), ">=" & (wk1), BD.Range("AK:AK"), _
"<" & (wk2))
Next
Using absolute and relative references in our formulas allow us to write formulas to multiple cells at once.
Sub ConstData()
Dim CurrentMonth As Date
CurrentMonth = DateSerial(Year(Date), Month(Date), 1)
With ThisWorkbook.Sheets("MonthData").Range("TC_Month")
.Range("B2:F2").Value = Array(CurrentMonth, CurrentMonth + 7, CurrentMonth + 14, CurrentMonth + 21, CurrentMonth + 28)
.Range("B3:E7").Formula = "=COUNTIFS(BuiltData!$AF:$AF, $A3, BuiltData!$R:$R, "">250"", BuiltData!$AK:$AK, "">=""&B$2, BuiltData!$AK:$AK, ""<""&C$2)"
.Range("F3:F7").Formula = "=COUNTIFS(BuiltData!$AF:$AF, $A3, BuiltData!$R:$R, "">250"", BuiltData!$AK:$AK, "">=""&F$2)"
.Value = .Value ' This line converts the formulas into values
End With
End Sub
Refactored code
I simplified my code example for readability.
Sub ConstData()
Dim wb As Workbook, BD As Worksheet, YD As Worksheet, MD As Worksheet
Set wb = ThisWorkbook
Set BD = wb.Sheets("BuiltData")
Set YD = wb.Sheets("YearData")
Set MD = wb.Sheets("MonthData")
MD.Activate
Dim CurrentMonth As Date
CurrentMonth = DateSerial(Year(Date), Month(Date), 1)
With MD.Range("TC_Month")
Rem I perfer to use r for row and c for column for readability
Dim r As Long, c As Long
Rem Adding 7 to a Date is the same as DateAdd("d", 7, Date)
For c = 2 To 6
.Cells(2, c).Value = (c - 2) * 7 + CurrentMonth
Next
Dim weekStart As Date, weekEnd As Date
Dim Associate As String
Rem Rows 3 to 7
For r = 3 To 7
Associate = .Cells(r, 1).Value
Rem Columns 2 to 5
For c = 2 To 5
weekStart = .Cells(2, c).Value
weekEnd = .Cells(2, c + 1).Value
.Cells(r, c).Value = WorksheetFunction.CountIfs(BD.Range("AF:AF"), _
Associate, _
BD.Range("R:R"), ">250", _
BD.Range("AK:AK"), ">=" & weekStart, _
BD.Range("AK:AK"), _
"<" & weekEnd)
Next
Rem Column 6 Should have a different fromula
weekStart = .Cells(2, 6).Value
.Cells(r, 6).Value = WorksheetFunction.CountIfs(BD.Range("AF:AF"), _
Associate, _
BD.Range("R:R"), ">250", _
BD.Range("AK:AK"), ">=" & weekStart)
Next
End With
End Sub
Something like this should work (untested)
Sub ConstData()
Dim wb As Workbook, BD As Worksheet, YD As Worksheet, MD As Worksheet
Dim wk1 As Date, rngDates As Range, rngNames As Range, cD As Range, cN As Range
Dim rngData As Range
Set wb = ThisWorkbook
Set BD = wb.Sheets("BuiltData")
Set YD = wb.Sheets("YearData")
Set MD = wb.Sheets("MonthData")
Set rngData = MD.Range("TC_Month")
Set rngNames = rngData.Cells(3, 1).Resize(5) 'range with associates
Set rngDates = rngData.Cells(2, 2).Resize(1, 5) 'range with dates
wk1 = DateSerial(Year(Date), Month(Date), 1) 'start date
For Each cD In rngDates 'for each date cell
cD.Value2 = wk1 'populate date value
wk1 = wk1 + 7 'add a week
For Each cN In rngNames 'cells with associates
'populate the value
MD.Cells(cN.Row, cD.Column).Value = Application.CountIfs( _
BD.Range("AF:AF"), cN.Value, _
BD.Range("R:R"), ">250", _
BD.Range("AK:AK"), ">=" & CLng(cD.Value), _
BD.Range("AK:AK"), "<" & CLng(cD.Value + 7))
Next cN
Next cD
End Sub