Creating a single Table with different formulas Excel VBA

**Bob Phillips** · 05-01-2020, 01:18 AM

What is that picture supposed to be showing?

**jazz2409** · 05-01-2020, 01:26 AM

I mean for weeks 3/2/2020, 3/23/2020, and 4/13/2020 category 1a is F but on the table they're still color green

**Bob Phillips** · 05-01-2020, 02:20 AM

Ah, you never said you wanted it to be week specific as well, you just mentioned P or F on sub-category, and your example showed applying the same test to all 8 columns, which you plainly cannot do if you are checking the date as well. Weekly might be doable, but what about Monthly? First the vcolumn L already has a value in it, month, and the dates are some MTD, so what date should be checked against?

**jazz2409** · 05-01-2020, 03:05 AM

Hello, can it be like while getting the data for weekly/monthly the value on column L will be checked as well so it wi be colored based on what's in column L? Sorry I'm not really good at explaining things

**Bob Phillips** · 05-01-2020, 03:20 AM

Clearly not. As I said, weekly is simple because the dates in column H are the same dates as we setup on the analysis sheet. Monthly is harder, as column L holds a month value not a P or F, and the date is some date in the month, whereas the analysis is month end date.

This will slow the code down considerably with all the extra looping.

**jazz2409** · 05-01-2020, 03:45 AM

Hmmm on my monthly sheet, I will only have two dates.. Those dates will be the same as what's on the analysis sheet.. And my column L in monthly sheet is the P/F column.. So if the EOMONTH column isn't available on the Monthly Sheet, the color will just be black..
a.jpg

**Bob Phillips** · 05-01-2020, 04:14 AM

You've changed the layout of the Monthly sheet, you added another column before the previous column L. If I was working with you and you did that without telling me I would not be very impressed.

As I said, it is much slower, even on this small set of data.

Public Sub CategoryAnalysis()
Const MSG_TITLE As String = "Category Analysis"
Const HEAD_START As Long = 5
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, ii As Long

    On Error GoTo cat_error

    Application.ScreenUpdating = False
    Application.Calculation = xlCalculationManual
    
    Set database = Worksheets("Database")
    With Worksheets("Table")
    
        SetupHeadings HEAD_START
        nextrow = HEAD_START + 2
        
        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)
            
            For ii = 3 To 4
            
                With .Cells(nextrow, ii)
                
                    monthlyrow = MatchRow("Monthly", level, database.Cells(i, "D").Value, Worksheets("Table").Cells(HEAD_START + 1, ii).Value)
                    If monthlyrow > 0 Then
                    
                        Select Case Worksheets("Monthly").Cells(monthlyrow, "L").Value
                            
                            Case "P":   .Font.Color = vbGreen
                            Case "F":   .Font.Color = vbRed
                        End Select
                    End If
                End With
            Next ii
            
            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
            
            For ii = 5 To 12
            
                With .Cells(nextrow, ii)
            
                    weeklyrow = MatchRow("Weekly", level, database.Cells(i, "D").Value, Worksheets("Table").Cells(HEAD_START + 1, ii).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
            Next ii
            
            nextrow = nextrow + 1
        Next i
    End With
    
    MsgBox "All done", vbOKOnly + vbInformation, MSG_TITLE

cat_exit:
    Application.Calculation = xlCalculationAutomatic
    Application.ScreenUpdating = True
    
    Exit Sub

cat_error:
    MsgBox "Something went wrong" & vbNewLine & _
           " error number: " & Err.Number & vbNewLine & _
           " error description: " & Err.Description, vbOKOnly + vbCritical, MSG_TITLE
End Sub

Private Sub SetupHeadings(ByVal loc As Long)

    With Worksheets("Table").Cells(loc, "A")
    
        .Range("A1:L1").Value = Array(vbNullString, vbNullString, "MTD", "MTD -1", "WEEK 0", "WEEK -1", "WEEK -2", "WEEK -3", "WEEK -4", "WEEK -5", "WEEK -6", "WEEK -7")
        .Range("C1:D1").Interior.Color = RGB(84, 130, 53)
        .Range("E1:L1").Interior.Color = RGB(142, 169, 219)
        .Range("A1:L1").Font.Color = vbWhite
        .Range("A2:B2").Value = Array("CATEGORY", "TARGET")
        .Range("A2:D2").Interior.Color = RGB(198, 224, 180)
        .Range("E2:L2").Interior.Color = RGB(180, 198, 231)
        .Range("C2").FormulaArray = "=MAX(IF(Monthly!C13=Table!R1C2,Monthly!C8))"
        .Range("D2").FormulaR1C1 = "=EOMONTH(RC[-1],-1)"
        .Range("E2").FormulaR1C1 = "=MAX(Weekly!C8)"
        .Range("C2:L2").NumberFormat = "dd-mmm"
        .Range("F2:L2").FormulaR1C1 = "=RC[-1]-7"
        .Range("A1:L2").HorizontalAlignment = xlCenter
        .Range("A1:L2").Font.Bold = True
    End With
End Sub

Private Function MatchRow(ByRef sh As String, ByVal cat As String, ByVal subcat As String, ByVal week As Date) As Long

    On Error Resume Next
    MatchRow = Application.Evaluate("Match(1, ('" & sh & "'!A:A=""" & cat & """)*('" & sh & "'!D:D=""" & subcat & """)*('" & sh & "'!H:H=" & CLng(week) & "),0)")
End Function

**Bob Phillips** · 05-01-2020, 04:52 AM

This is much quicker

Public Sub CategoryAnalysis()
Const MSG_TITLE As String = "Category Analysis"
Const HEAD_START As Long = 5
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 Variant
Dim level As String
Dim weeklyrow As Long, monthlyrow As Long
Dim nextrow As Long, lastrow As Long
Dim i As Long, ii As Long
Dim starttime As Double

    On Error GoTo cat_error
    
    starttime = Timer

    Application.ScreenUpdating = False
    Application.Calculation = xlCalculationManual
    
    With Worksheets("Weekly")
    
        lastrow = .Cells(.Rows.Count, "A").End(xlUp).Row
        .Range("N2").Resize(lastrow - 1).Formula = "=A2&D2&INT(H2)"
    End With
    
    With Worksheets("Monthly")
    
        lastrow = .Cells(.Rows.Count, "A").End(xlUp).Row
        .Range("N2").Resize(lastrow - 1).Formula = "=A2&D2&INT(H2)"
    End With
    
    database = Worksheets("Database").UsedRange
    With Worksheets("Table")
    
        SetupHeadings HEAD_START
        nextrow = HEAD_START + 2
        
        level = vbNullString
        For i = LBound(database, 1) + 1 To UBound(database, 1)
        
            'setup category row text, formulas and formats
            If database(i, 1) <> level Then
            
                level = database(i, 1)
                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(i, 4)
                .Font.Italic = True
                .HorizontalAlignment = xlLeft
                .IndentLevel = 1
            End With
            
            .Cells(nextrow, "B").Value = database(i, 6)
            
            .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)
            
            For ii = 3 To 4
            
                With .Cells(nextrow, ii)
                
'                    monthlyrow = MatchRow("Monthly", level, database(i, 4), Worksheets("Table").Cells(HEAD_START + 1, ii).Value)
                    monthlyrow = MatchIt("Monthly", level & database(i, 4) & CLng(Worksheets("Table").Cells(HEAD_START + 1, ii).Value))
                    If monthlyrow > 0 Then
                    
                        Select Case Worksheets("Monthly").Cells(monthlyrow, "L").Value
                            
                            Case "P":   .Font.Color = vbGreen
                            Case "F":   .Font.Color = vbRed
                        End Select
                    End If
                End With
            Next ii
            
            With .Cells(nextrow, "C").Resize(1, 10)
            
                Select Case database(i, 8)
                    
                    Case "Percentage":  .NumberFormat = "0%"
                    Case "Decimal":     .NumberFormat = "#0.000"
                End Select
                .Font.Size = 8
                .Font.Bold = False
                .HorizontalAlignment = xlCenter
            End With
            
            For ii = 5 To 12
            
                With .Cells(nextrow, ii)
            
'                    weeklyrow = MatchRow("Weekly", level, database(i, 4), Worksheets("Table").Cells(HEAD_START + 1, ii).Value)
                    weeklyrow = MatchIt("Weekly", level & database(i, 4) & CLng(Worksheets("Table").Cells(HEAD_START + 1, ii).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
            Next ii
            Debug.Print nextrow
            nextrow = nextrow + 1
        Next i
    End With
    
    Worksheets("Weekly").Columns("N").Delete
    Worksheets("Monthly").Columns("N").Delete
    
    Debug.Print "Elapsed time: " & Timer - starttime
    MsgBox "All done", vbOKOnly + vbInformation, MSG_TITLE

cat_exit:
    Application.Calculation = xlCalculationAutomatic
    Application.ScreenUpdating = True
    
    Exit Sub

cat_error:
    MsgBox "Something went wrong" & vbNewLine & _
           " error number: " & Err.Number & vbNewLine & _
           " error description: " & Err.Description, vbOKOnly + vbCritical, MSG_TITLE
End Sub

Private Sub SetupHeadings(ByVal loc As Long)

    With Worksheets("Table").Cells(loc, "A")
    
        .Range("A1:L1").Value = Array(vbNullString, vbNullString, "MTD", "MTD -1", "WEEK 0", "WEEK -1", "WEEK -2", "WEEK -3", "WEEK -4", "WEEK -5", "WEEK -6", "WEEK -7")
        .Range("C1:D1").Interior.Color = RGB(84, 130, 53)
        .Range("E1:L1").Interior.Color = RGB(142, 169, 219)
        .Range("A1:L1").Font.Color = vbWhite
        .Range("A2:B2").Value = Array("CATEGORY", "TARGET")
        .Range("A2:D2").Interior.Color = RGB(198, 224, 180)
        .Range("E2:L2").Interior.Color = RGB(180, 198, 231)
        .Range("C2").FormulaArray = "=MAX(IF(Monthly!C13=Table!R1C2,Monthly!C8))"
        .Range("D2").FormulaR1C1 = "=EOMONTH(RC[-1],-1)"
        .Range("E2").FormulaR1C1 = "=MAX(Weekly!C8)"
        .Range("C2:L2").NumberFormat = "dd-mmm"
        .Range("F2:L2").FormulaR1C1 = "=RC[-1]-7"
        .Range("A1:L2").HorizontalAlignment = xlCenter
        .Range("A1:L2").Font.Bold = True
    End With
End Sub

Private Function MatchRow(ByRef sh As String, ByVal cat As String, ByVal subcat As String, ByVal week As Date) As Long

    On Error Resume Next
    MatchRow = Application.Evaluate("Match(1, ('" & sh & "'!A:A=""" & cat & """)*('" & sh & "'!D:D=""" & subcat & """)*('" & sh & "'!H:H=" & CLng(week) & "),0)")
End Function

Private Function MatchIt(ByRef sh As String, ByVal lookupval) As Long

    On Error Resume Next
    MatchIt = Application.Match(lookupval, Worksheets(sh).Columns(14), 0)
End Function

**jazz2409** · 05-01-2020, 07:08 PM

works perfectly

thank you so much for being so patient with me.

**jazz2409** · 05-01-2020, 08:36 PM

Wait I just noticed... The others are not being colored, they remain black
a.jpg

**jazz2409** · 05-01-2020, 08:56 PM

I've fixed it

a.jpg
thank you, xld

**Bob Phillips** · 05-02-2020, 05:32 AM

What was the problem/fix? Was it no value in the Weekly column?

**jazz2409** · 05-02-2020, 06:35 AM

Originally Posted by xld

What was the problem/fix? Was it no value in the Weekly column?

Honestly I'm not sure. I edited the HEADSTART + 1 but when I compared it to your codes here, it's the same. So technically I didn't change anything but for some reason it didn't work the first time. Weird.

**Bob Phillips** · 05-02-2020, 10:06 AM

I also noticed that in your pic in post #50, there seems to be two extra lines. Are you still getting that, as I saw that here at some point and know the cause and how to fix it.

**jazz2409** · 05-02-2020, 08:19 PM

Yes that's still showing, I just removed them in post 51

Also in this part:

 '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)

What can be done in order to just copy and paste everything in database.Cells(i,"F") as they are? The percentages are changing to decimals

**SamT** · 05-03-2020, 02:03 AM

.Cells(nextrow, "B").Text = da...

**Bob Phillips** · 05-03-2020, 03:24 AM

Sam's suggestion won't work. Text is a read-only property.

This revamped code is tidier, and should address the outstanding issues.

Const MSG_TITLE As String = "Category Analysis"
Const HEAD_START As Long = 5
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)"
    
Public Sub CategoryAnalysis()
Dim database As Variant
Dim category As String
Dim weeklyrow As Long, monthlyrow As Long
Dim numItems As Long, items As Variant
Dim nextrow As Long, lastrow As Long
Dim i As Long, ii As Long
Dim starttime As Double

    On Error GoTo cat_error
    
    starttime = Timer

    Application.ScreenUpdating = False
    Application.Calculation = xlCalculationManual
    
    With Worksheets("Weekly")
    
        lastrow = .Cells(.Rows.Count, "A").End(xlUp).Row
        .Range("N2").Resize(lastrow - 1).Formula = "=A2&D2&INT(H2)"
    End With
    
    With Worksheets("Monthly")
    
        lastrow = .Cells(.Rows.Count, "A").End(xlUp).Row
        .Range("N2").Resize(lastrow - 1).Formula = "=A2&D2&INT(H2)"
    End With
    
    With Worksheets("Database")

        lastrow = .Cells(.Rows.Count, "A").End(xlUp).Row
        .Range("N2").Resize(lastrow - 1).Formula = "=A2&D2"
        database = .Range("A2").Resize(lastrow - 1, 8)
    End With
    
    With Worksheets("Table")
    
        SetupHeadings HEAD_START
        nextrow = HEAD_START + 2
        
        category = vbNullString
        For i = LBound(database, 1) To UBound(database, 1)
        
            'setup category row text, formulas and formats
            If database(i, 1) <> category Then
            
                category = database(i, 1)
                SetupCategoryRow nextrow, category
            
                nextrow = nextrow + 1
            End If
            
            'now setup a sub-category row
            SetupSubcategoryRow nextrow, category, database(i, 4)
            SetValuesColour Worksheets("Monthly"), nextrow, 3, 4, category, database(i, 4)
            SetValuesFormat Worksheets("Table").Cells(nextrow, "C").Resize(1, 10), database(i, 8)
            SetValuesColour Worksheets("Weekly"), nextrow, 5, 12, category, database(i, 4)
            
            nextrow = nextrow + 1
        Next i
    End With
    
    Worksheets("Weekly").Columns("N").Delete
    Worksheets("Monthly").Columns("N").Delete
    Worksheets("Database").Columns("N").Delete

cat_exit:
    Range("A6").Select
    Application.Calculation = xlCalculationAutomatic
    Application.ScreenUpdating = True
    
    MsgBox "All done", vbOKOnly + vbInformation, MSG_TITLE
    
    Debug.Print "Elapsed time: " & Timer - starttime
    Exit Sub

cat_error:
    MsgBox "Something went wrong" & vbNewLine & _
           " error number: " & Err.Number & vbNewLine & _
           " error description: " & Err.Description, vbOKOnly + vbCritical, MSG_TITLE
End Sub

Private Function SetupHeadings(ByVal loc As Long) As Boolean
    With Worksheets("Table").Cells(loc, "A")
        .Range("A1:L1").Value = Array(vbNullString, vbNullString, "MTD", "MTD -1", _
                                      "WEEK 0", "WEEK -1", "WEEK -2", "WEEK -3", "WEEK -4", "WEEK -5", "WEEK -6", "WEEK -7")
        .Range("C1:D1").Interior.Color = RGB(84, 130, 53)
        .Range("E1:L1").Interior.Color = RGB(142, 169, 219)
        .Range("A1:L1").Font.Color = vbWhite
        .Range("A2:B2").Value = Array("CATEGORY", "TARGET")
        .Range("A2:D2").Interior.Color = RGB(198, 224, 180)
        .Range("E2:L2").Interior.Color = RGB(180, 198, 231)
        .Range("C2").FormulaArray = "=MAX(IF(Monthly!C13=Table!R1C2,Monthly!C8))"
        .Range("D2").FormulaR1C1 = "=EOMONTH(RC[-1],-1)"
        .Range("E2").FormulaR1C1 = "=MAX(Weekly!C8)"
        .Range("C2:L2").NumberFormat = "dd-mmm"
        .Range("F2:L2").FormulaR1C1 = "=RC[-1]-7"
        .Range("A1:L2").HorizontalAlignment = xlCenter
        .Range("A1:L2").Font.Bold = True
    End With
End Function

Public Function SetupCategoryRow(ByVal TargetRow As Long, ByVal category As Variant) As Boolean

    With Worksheets("Table")
            
        With .Cells(TargetRow, "A")
        
            .Value = category
            .Font.Italic = False
            .HorizontalAlignment = xlLeft
            .IndentLevel = 0
        End With

        .Cells(TargetRow, "C").Resize(1, 2).FormulaR1C1 = Replace(FORMULA_CATEGORY, "<period>", "Monthly")
        .Cells(TargetRow, "E").Resize(1, 8).FormulaR1C1 = Replace(FORMULA_CATEGORY, "<period>", "Weekly")
            
        With .Cells(TargetRow, "C").Resize(1, 10)
        
            .NumberFormat = "0%"
            .Font.ColorIndex = xlColorIndexAutomatic
            .Font.Size = 10
            .Font.Bold = True
            .HorizontalAlignment = xlCenter
        End With
    End With
End Function

Public Function SetupSubcategoryRow(ByVal TargetRow As Long, ByVal category As Variant, ByVal Subcategory As Variant) As Boolean
Dim matchidx As Long
 
    With Worksheets("Table")
        
        With .Cells(TargetRow, "A")
        
            .Value = Subcategory
            .Font.Italic = True
            .HorizontalAlignment = xlLeft
            .IndentLevel = 1
        End With
        
        matchidx = MatchIt(category & Subcategory, Worksheets("Database").Columns(14))
        If matchidx > 0 Then
        
            .Cells(TargetRow, "B").Value = Worksheets("Database").Cells(matchidx, "F").Text
            .Cells(TargetRow, "B").NumberFormat = Worksheets("Database").Cells(matchidx, "F").NumberFormat
        End If
        
        .Cells(TargetRow, "C").Resize(1, 2).FormulaR1C1 = Replace(Replace(FORMULA_SUB_CATEGORY, "<period>", "Monthly"), "<level>", category)
        .Cells(TargetRow, "E").Resize(1, 8).FormulaR1C1 = Replace(Replace(FORMULA_SUB_CATEGORY, "<period>", "Weekly"), "<level>", category)
    End With
End Function

Private Function SetValuesColour(ByRef sh As Worksheet, ByVal TargetRow As Long, ByVal StartCol As Long, EndCol As Long, _
    ByVal category As String, Subcategory As Variant) As Boolean
Dim matchRow As Long
Dim i As Long

    With Worksheets("Table")
    
        For i = StartCol To EndCol
        
            matchRow = MatchIt(category & Subcategory & CLng(.Cells(HEAD_START + 1, i).Value), sh.Columns(14))
            If matchRow > 0 Then
            
                Select Case sh.Cells(matchRow, "L").Value
                    
                    Case "P":   .Cells(TargetRow, i).Font.Color = vbGreen
                    Case "F":   .Cells(TargetRow, i).Font.Color = vbRed
                End Select
            End If
        Next i
    End With
End Function

Private Function SetValuesFormat(ByRef Target As Range, ByVal FormatValue As Variant) As Boolean

    With Target
        
        Select Case FormatValue
            
            Case "Percentage":  .NumberFormat = "0%"
            Case "Decimal":     .NumberFormat = "#0.000"
        End Select
        .Font.Size = 8
        .Font.Bold = False
        .HorizontalAlignment = xlCenter
    End With
End Function

Private Function MatchIt(ByVal lookupval, ByVal LookupIn As Range) As Long
    On Error Resume Next
    MatchIt = Application.Match(lookupval, LookupIn, 0)
End Function

**jazz2409** · 05-03-2020, 07:59 PM

Let me try

**jazz2409** · 05-04-2020, 12:32 AM

I have a question, though.

 'now setup a sub-category row            SetupSubcategoryRow nextrow, category, database(i, 4)
            SetValuesColour Worksheets("Monthly"), nextrow, 3, 4, category, database(i, 4)
            SetValuesFormat Worksheets("Table").Cells(nextrow, "C").Resize(1, 10), database(i, 8)
            SetValuesColour Worksheets("Weekly"), nextrow, 5, 12, category, database(i, 4)

My Format column in Database has been moved to column J because they added a new column in before Format column. I tried changing it to:

 'now setup a sub-category row            SetupSubcategoryRow nextrow, category, database(i, 4)
            SetValuesColour Worksheets("Monthly"), nextrow, 3, 4, category, database(i, 4)
            SetValuesFormat Worksheets("Table").Cells(nextrow, "C").Resize(1, 10), database(i, 10)
            SetValuesColour Worksheets("Weekly"), nextrow, 5, 12, category, database(i, 4)

but I got an error saying Subscript out of range so I changed

 With Worksheets("Database")

        lastrow = .Cells(.Rows.Count, "A").End(xlUp).Row
        .Range("N2").Resize(lastrow - 1).Formula = "=A2&D2"
        database = .Range("A2").Resize(lastrow - 1, 8)
    End With

to

 With Worksheets("Database")

        lastrow = .Cells(.Rows.Count, "A").End(xlUp).Row
        .Range("N2").Resize(lastrow - 1).Formula = "=A2&D2"
        database = .Range("A2").Resize(lastrow - 1, 10)
    End With

but I got more errors after that. What do I do?

**Bob Phillips** · 05-04-2020, 01:26 AM

Why did you change it to database (i, 10) instead of database (I, 9) if you only added one column?

What I tend to do in my work is to create a column enum, and reference columns numbers by the enum entry, then if I add a column I just add an item to the enum.

Something like this

Enum colDatabase
    Category = 1
    X1
    X2
    Subcategory
    X3
    Target
    X4
    Format
End Enum

and then I would refence database like so

SetValuesFormat Worksheets("Table").Cells(nextrow, "C").Resize(1, 10), database(i, colDatabase.Format)

and then in your case you would just add a line X5 or some such before Format and no need to change any of the coding statements.

Thread: Creating a single Table with different formulas Excel VBA

Thread Tools

Display

Tags for this Thread

Posting Permissions