Page 2 of 4 FirstFirst 1 2 3 4 LastLast
Results 21 to 40 of 79

Thread: Creating a single Table with different formulas Excel VBA

  1. #21
    VBAX Sage SamT's Avatar
    Joined
    Oct 2006
    Location
    Near Columbia
    Posts
    7,709
    Location
    Sorry but is there any chance that I can still continue with my sample workbook? I
    You can, but I'm not going to try to unravel that washtub of spaghetti. And you can tell your management that I said they are asking for a short road to hell.

    By the way, I am going to merge AaliiyahN82's thread relating to this issue into this thread.
    I expect the student to do their homework and find all the errrors I leeve in.


    Please take the time to read the Forum FAQ

  2. #22
    Distinguished Lord of VBAX VBAX Grand Master Bob Phillips's Avatar
    Joined
    Apr 2005
    Posts
    25,446
    Location
    Is this any use for you?

    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>!C8,Table!R6C,<period>!C4,Table!RC1)"
    Dim database As Worksheet
    Dim level As String
    Dim nextrow As Long
    Dim lastrow As Long
    Dim i As Long
    
        
        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
            
                If database.Cells(i, "A").Value <> level Then
                
                    level = database.Cells(i, "A").Value
                    .Cells(nextrow, "A").Value = level
                    .Cells(nextrow, "C").Resize(1, 2).FormulaR1C1 = Replace(FORMULA_CATEGORY, "<period>", "Monthly")
                    .Cells(nextrow, "E").Resize(1, 8).FormulaR1C1 = Replace(FORMULA_CATEGORY, "<period>", "Weekly")
                    .Cells(nextrow, "C").Resize(1, 10).NumberFormat = "0%"
                    .Cells(nextrow, "C").Resize(1, 10).Font.Bold = True
                    .Cells(nextrow, "C").Resize(1, 10).HorizontalAlignment = xlCenter
                    
                    nextrow = nextrow + 1
                End If
                
                .Cells(nextrow, "A").Value = database.Cells(i, "D").Value
                .Cells(nextrow, "A").Font.Italic = True
                .Cells(nextrow, "A").HorizontalAlignment = xlLeft
                .Cells(nextrow, "A").IndentLevel = 1
                .Cells(nextrow, "C").Resize(1, 2).FormulaR1C1 = Replace(FORMULA_SUB_CATEGORY, "<period>", "Monthly")
                .Cells(nextrow, "E").Resize(1, 8).FormulaR1C1 = Replace(FORMULA_SUB_CATEGORY, "<period>", "Weekly")
                .Cells(nextrow, "C").Resize(1, 10).HorizontalAlignment = xlCenter
                Select Case database.Cells(i, "H").Value
                    
                    Case "Percentage"
                        
                        .Cells(nextrow, "C").Resize(1, 10).NumberFormat = "0%"
                        
                    Case "Decimal"
                    
                        .Cells(nextrow, "C").Resize(1, 10).NumberFormat = "#0.000"
                End Select
                
                nextrow = nextrow + 1
            Next i
        End With
    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
    ____________________________________________
    Nihil simul inventum est et perfectum

    Abusus non tollit usum

    Last night I dreamed of a small consolation enjoyed only by the blind: Nobody knows the trouble I've not seen!
    James Thurber

  3. #23
    VBAX Tutor
    Joined
    Jan 2020
    Posts
    204
    Location
    Quote Originally Posted by xld View Post
    Is this any use for you?

    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>!C8,Table!R6C,<period>!C4,Table!RC1)"
    Dim database As Worksheet
    Dim level As String
    Dim nextrow As Long
    Dim lastrow As Long
    Dim i As Long
    
        
        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
            
                If database.Cells(i, "A").Value <> level Then
                
                    level = database.Cells(i, "A").Value
                    .Cells(nextrow, "A").Value = level
                    .Cells(nextrow, "C").Resize(1, 2).FormulaR1C1 = Replace(FORMULA_CATEGORY, "<period>", "Monthly")
                    .Cells(nextrow, "E").Resize(1, 8).FormulaR1C1 = Replace(FORMULA_CATEGORY, "<period>", "Weekly")
                    .Cells(nextrow, "C").Resize(1, 10).NumberFormat = "0%"
                    .Cells(nextrow, "C").Resize(1, 10).Font.Bold = True
                    .Cells(nextrow, "C").Resize(1, 10).HorizontalAlignment = xlCenter
                    
                    nextrow = nextrow + 1
                End If
                
                .Cells(nextrow, "A").Value = database.Cells(i, "D").Value
                .Cells(nextrow, "A").Font.Italic = True
                .Cells(nextrow, "A").HorizontalAlignment = xlLeft
                .Cells(nextrow, "A").IndentLevel = 1
                .Cells(nextrow, "C").Resize(1, 2).FormulaR1C1 = Replace(FORMULA_SUB_CATEGORY, "<period>", "Monthly")
                .Cells(nextrow, "E").Resize(1, 8).FormulaR1C1 = Replace(FORMULA_SUB_CATEGORY, "<period>", "Weekly")
                .Cells(nextrow, "C").Resize(1, 10).HorizontalAlignment = xlCenter
                Select Case database.Cells(i, "H").Value
                    
                    Case "Percentage"
                        
                        .Cells(nextrow, "C").Resize(1, 10).NumberFormat = "0%"
                        
                    Case "Decimal"
                    
                        .Cells(nextrow, "C").Resize(1, 10).NumberFormat = "#0.000"
                End Select
                
                nextrow = nextrow + 1
            Next i
        End With
    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
    hello, the highlighted has to be taken into consideration for the ones that are in italics. Basically the ones that in italics already have values that are on the weekly and monthly sheets, we just need to look them up from those sheets and then put them into the table.

    Capture.jpg

  4. #24
    VBAX Tutor
    Joined
    Jan 2020
    Posts
    204
    Location
    Quote Originally Posted by SamT View Post
    You can, but I'm not going to try to unravel that washtub of spaghetti. And you can tell your management that I said they are asking for a short road to hell.

    By the way, I am going to merge AaliiyahN82's thread relating to this issue into this thread.
    Hahaha I wish I could just tell them to "gfy" without losing my job.

  5. #25
    VBAX Sage SamT's Avatar
    Joined
    Oct 2006
    Location
    Near Columbia
    Posts
    7,709
    Location
    I got friends down that way


    Take it home and in your own time do it the right way, Then at work just treat their workbook as a Report and use your book to fill in the blanks once a week.


    Seriously, you could create the "Right way" on xlVeryHidden sheets and then fill in the blanks on their Report sheets. Report sheets do belong to those who need the Reports, It's just our job to fill in the blanks on their Reports. I don't usually even think about Reports until I have at least a rough draft of the Data Base sheets, but you might have to work bass ackwards.
    Last edited by SamT; 04-29-2020 at 08:11 PM.
    I expect the student to do their homework and find all the errrors I leeve in.


    Please take the time to read the Forum FAQ

  6. #26
    VBAX Tutor
    Joined
    Jan 2020
    Posts
    204
    Location
    Quote Originally Posted by SamT View Post
    I got friends down that way


    Take it home and in your own time do it the right way, Then at work just treat their workbook as a Report and use your book to fill in the blanks once a week.


    Seriously, you could create the "Right way" on xlVeryHidden sheets and then fill in the blanks on their Report sheets. Report sheets do belong to those who need the Reports, It's just our job to fill in the blanks on their Reports. I don't usually even think about Reports until I have at least a rough draft of the Data Base sheets, but you might have to work bass ackwards.
    I am taking your advice, I will follow the workbook you attached. Maybe I can show it to them and make them realize you're right

    For now I just really need to once and for all solve this thing right here so I'll have something to present to them tomorrow morning.

  7. #27
    Distinguished Lord of VBAX VBAX Grand Master Bob Phillips's Avatar
    Joined
    Apr 2005
    Posts
    25,446
    Location
    Quote Originally Posted by jazz2409 View Post
    hello, the highlighted has to be taken into consideration for the ones that are in italics. Basically the ones that in italics already have values that are on the weekly and monthly sheets, we just need to look them up from those sheets and then put them into the table.

    Capture.jpg
    Isn't that what my code does?
    ____________________________________________
    Nihil simul inventum est et perfectum

    Abusus non tollit usum

    Last night I dreamed of a small consolation enjoyed only by the blind: Nobody knows the trouble I've not seen!
    James Thurber

  8. #28
    Distinguished Lord of VBAX VBAX Grand Master Bob Phillips's Avatar
    Joined
    Apr 2005
    Posts
    25,446
    Location
    What I mean is that Category 1a, Category 1b are subs of Category 1, so by testing the sub-category you are automatically testing the category. No need to include both.
    ____________________________________________
    Nihil simul inventum est et perfectum

    Abusus non tollit usum

    Last night I dreamed of a small consolation enjoyed only by the blind: Nobody knows the trouble I've not seen!
    James Thurber

  9. #29
    VBAX Tutor
    Joined
    Jan 2020
    Posts
    204
    Location
    Quote Originally Posted by xld View Post
    What I mean is that Category 1a, Category 1b are subs of Category 1, so by testing the sub-category you are automatically testing the category. No need to include both.

    Hello, yes it actually does do that.. It's just that I forgot to mention that some sub categories repeat for other main categories...

  10. #30
    Distinguished Lord of VBAX VBAX Grand Master Bob Phillips's Avatar
    Joined
    Apr 2005
    Posts
    25,446
    Location
    Easily added in.

    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 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, 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
                
                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
    ____________________________________________
    Nihil simul inventum est et perfectum

    Abusus non tollit usum

    Last night I dreamed of a small consolation enjoyed only by the blind: Nobody knows the trouble I've not seen!
    James Thurber

  11. #31
    VBAX Tutor
    Joined
    Jan 2020
    Posts
    204
    Location
    THANK YOU SO MUCH!
    We'll have something to present in our zoom meeting later because of all of you here

    Last edited by Bob Phillips; 04-30-2020 at 04:41 AM. Reason: Removed unnecessary code quote

  12. #32
    VBAX Tutor
    Joined
    Jan 2020
    Posts
    204
    Location
    I can't tag the thread as solved... Why?

  13. #33
    Distinguished Lord of VBAX VBAX Grand Master Bob Phillips's Avatar
    Joined
    Apr 2005
    Posts
    25,446
    Location
    It is in the Thread Tools link towards the top of the page. I have done it for you this time.
    ____________________________________________
    Nihil simul inventum est et perfectum

    Abusus non tollit usum

    Last night I dreamed of a small consolation enjoyed only by the blind: Nobody knows the trouble I've not seen!
    James Thurber

  14. #34
    VBAX Tutor
    Joined
    Jan 2020
    Posts
    204
    Location
    Quote Originally Posted by xld View Post
    It is in the Thread Tools link towards the top of the page. I have done it for you this time.
    Hello, Sorry how do I add this line:

              With .Cells(nextrow, "G").Resize(1, 8)
                    Select Case Worksheets("Weekly").Cells(i, "L").Value
                        
                        Case "P":  .Font.Color = vbGreen
                        Case "F":  .Font.Color = vbRed
                    End Select
                    .Font.Size = 8
                    .Font.Bold = False
                    .HorizontalAlignment = xlCenter
              End With

    It's for if the sub category says P on the weekly (for the weekly cells of sub categories)/monthly (for the monthly cells of sub categories)sheets, the numbers will be color green. And then if it's F, the numbers will be red. Just for sub categories.

    I tried adding it at the end after the select case statement for decimal/percentage. It worked while it was running but once it was done it went back to being black

  15. #35
    Distinguished Lord of VBAX VBAX Grand Master Bob Phillips's Avatar
    Joined
    Apr 2005
    Posts
    25,446
    Location
    Why Weekly sheet? Why column G? Why 8 columns?
    ____________________________________________
    Nihil simul inventum est et perfectum

    Abusus non tollit usum

    Last night I dreamed of a small consolation enjoyed only by the blind: Nobody knows the trouble I've not seen!
    James Thurber

  16. #36
    VBAX Tutor
    Joined
    Jan 2020
    Posts
    204
    Location
    Quote Originally Posted by xld View Post
    Why Weekly sheet? Why column G? Why 8 columns?
    I was thinking I'll have a different set of select case statements for weekly and monthly sheets
    Sorry it's supposedly column E. Based on the table the weekly numbers will be from E:L - that's why it's 8, as to what I understood it's resize to 8 columns?
    And then the one for monthly will be columns C : D and then resize(1,2)?

  17. #37
    Distinguished Lord of VBAX VBAX Grand Master Bob Phillips's Avatar
    Joined
    Apr 2005
    Posts
    25,446
    Location
    Column E makes more sense. Not sure which column in Monthly, I left it at L, you might need to change.

    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 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)
                
                    Select Case Worksheets("Monthly").Cells(i, "L").Value
                        
                        Case "P":   .Font.Color = vbGreen
                        Case "F":   .Font.Color = vbRed
                    End Select
                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)
                
                    Select Case Worksheets("Weekly").Cells(i, "L").Value
                        
                        Case "P":   .Font.Color = vbGreen
                        Case "F":   .Font.Color = vbRed
                    End Select
                End With
                
                nextrow = nextrow + 1
            Next i
        End With
    
        Application.ScreenUpdating = True
    End Sub
    ____________________________________________
    Nihil simul inventum est et perfectum

    Abusus non tollit usum

    Last night I dreamed of a small consolation enjoyed only by the blind: Nobody knows the trouble I've not seen!
    James Thurber

  18. #38
    VBAX Tutor
    Joined
    Jan 2020
    Posts
    204
    Location
    Didn't work... Well yes it did work but not quite. It only colors the entire row and nor per item

  19. #39
    Distinguished Lord of VBAX VBAX Grand Master Bob Phillips's Avatar
    Joined
    Apr 2005
    Posts
    25,446
    Location
    Ah yes, it is looking at Weekly and Monthly with the database row.

    See if this works.

    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
    ____________________________________________
    Nihil simul inventum est et perfectum

    Abusus non tollit usum

    Last night I dreamed of a small consolation enjoyed only by the blind: Nobody knows the trouble I've not seen!
    James Thurber

  20. #40
    VBAX Tutor
    Joined
    Jan 2020
    Posts
    204
    Location
    Still the samea.jpg

Tags for this Thread

Posting Permissions

  • You may not post new threads
  • You may not post replies
  • You may not post attachments
  • You may not edit your posts
  •