Public Sub CategoryAnalysis()
Const FORMULA_CATEGORY As String = _
"=IFERROR(COUNTIFS(<period>!C10,""P"",<period>!C8,Table!R6C,<period>!C1,Table!RC1)" & _
"/SUMIFS(<period>!C11,<period>!C8,Table!R6C,<period>!C1,Table!RC1),""-"")"
Const FORMULA_SUB_CATEGORY As String = _
"=SUMIFS(<period>!C9,<period>!C1,""<level>"",<period>!C8,Table!R6C,<period>!C4,Table!RC1)"
Dim database As Worksheet
Dim level As String
Dim weeklyrow As Long, monthlyrow As Long
Dim nextrow As Long, lastrow As Long
Dim i As Long
Application.ScreenUpdating = False
Set database = Worksheets("Database")
With Worksheets("Table")
SetupHeadings
nextrow = 7
lastrow = database.Cells(Rows.Count, "A").End(xlUp).Row
level = vbNullString
For i = 2 To lastrow
'setup category row text, formulas and formats
If database.Cells(i, "A").Value <> level Then
level = database.Cells(i, "A").Value
With .Cells(nextrow, "A")
.Value = level
.Font.Italic = False
.HorizontalAlignment = xlLeft
.IndentLevel = 0
End With
.Cells(nextrow, "C").Resize(1, 2).FormulaR1C1 = Replace(FORMULA_CATEGORY, "<period>", "Monthly")
.Cells(nextrow, "E").Resize(1, 8).FormulaR1C1 = Replace(FORMULA_CATEGORY, "<period>", "Weekly")
With .Cells(nextrow, "C").Resize(1, 10)
.NumberFormat = "0%"
.Font.Size = 10
.Font.Bold = True
.HorizontalAlignment = xlCenter
End With
nextrow = nextrow + 1
End If
'setup sub-category row text, formulas and formats
With .Cells(nextrow, "A")
.Value = database.Cells(i, "D").Value
.Font.Italic = True
.HorizontalAlignment = xlLeft
.IndentLevel = 1
End With
.Cells(nextrow, "B").Value = database.Cells(i, "F").Text
.Cells(nextrow, "C").Resize(1, 2).FormulaR1C1 = Replace(Replace(FORMULA_SUB_CATEGORY, "<period>", "Monthly"), "<level>", level)
.Cells(nextrow, "E").Resize(1, 8).FormulaR1C1 = Replace(Replace(FORMULA_SUB_CATEGORY, "<period>", "Weekly"), "<level>", level)
With .Cells(nextrow, "C").Resize(1, 2)
monthlyrow = MatchRow("Monthly", level, database.Cells(i, "D").Value)
If monthlyrow > 0 Then
Select Case Worksheets("Monthly").Cells(monthloyrow, "L").Value
Case "P": .Font.Color = vbGreen
Case "F": .Font.Color = vbRed
End Select
End If
End With
With .Cells(nextrow, "C").Resize(1, 10)
Select Case database.Cells(i, "H").Value
Case "Percentage": .NumberFormat = "0%"
Case "Decimal": .NumberFormat = "#0.000"
End Select
.Font.Size = 8
.Font.Bold = False
.HorizontalAlignment = xlCenter
End With
With .Cells(nextrow, "E").Resize(1, 8)
weeklyrow = MatchRow("Weekly", level, database.Cells(i, "D").Value)
If weeklyrow > 0 Then
Select Case Worksheets("Weekly").Cells(weeklyrow, "L").Value
Case "P": .Font.Color = vbGreen
Case "F": .Font.Color = vbRed
End Select
End If
End With
nextrow = nextrow + 1
Next i
End With
Application.ScreenUpdating = True
End Sub
Private Sub SetupHeadings()
With Worksheets("Table")
.Range("A5:L5").Value = Array(vbNullString, vbNullString, "MTD", "MTD -1", "WEEK 0", "WEEK -1", "WEEK -2", "WEEK -3", "WEEK -4", "WEEK -5", "WEEK -6", "WEEK -7")
.Range("C5:D5").Interior.Color = RGB(84, 130, 53)
.Range("E5:L5").Interior.Color = RGB(142, 169, 219)
.Range("A5:L5").Font.Color = vbWhite
.Range("A6:B6").Value = Array("CATEGORY", "TARGET")
.Range("A6:D6").Interior.Color = RGB(198, 224, 180)
.Range("E6:L6").Interior.Color = RGB(180, 198, 231)
.Range("C6").FormulaArray = "=MAX(IF(Monthly!C12=Table!R1C2,Monthly!C8))"
.Range("D6").FormulaR1C1 = "=EOMONTH(RC[-1],-1)"
.Range("E6").FormulaR1C1 = "=MAX(Weekly!C8)"
.Range("C6:L6").NumberFormat = "dd-mmm"
.Range("F6:L6").FormulaR1C1 = "=RC[-1]-7"
.Range("A5:L6").HorizontalAlignment = xlCenter
.Range("A5:L6").Font.Bold = True
End With
End Sub
Private Function MatchRow(ByRef sh As String, ByVal cat As String, ByVal subcat As String) As Long
On Error Resume Next
MatchRow = Application.Evaluate("Match(1, ('" & sh & "'!A:A=""" & cat & """)*('" & sh & "'!D:D=""" & subcat & """),0)")
End Function