Change Cells' color if sum items match

[Vincent88]

Hi Guys,
I want to change the color of font in rows of Column B if the sum amount meets the conditions. Please advise what should be corrected. Thanks in advance.

Sub vSum8()

    Application.DisplayStatusBar = False
    Application.EnableEvents = False
    Application.ScreenUpdating = False


    Dim rngg As Range
    Dim rnggRow As Range
    Dim i As Range
    Dim lastRow As Long
    Dim lastcol As Long
    Dim rnggCol As Range, rng1Row As Range
    Dim vDayB As Date, vDayE As Date
    Dim vColumnB As Range, vColumnE As Range
    
      
    ActiveWindow.ScrollColumn = 2
    
    lastRow = Cells(Rows.Count, "A").End(xlUp).Row
    lastcol = Cells(1, Columns.Count).End(xlToLeft).Column
    Set rngg = Range(Cells(1, 1), Cells(lastRow, lastcol))
    Set rnggCol = rngg.Columns(2).Cells(3).Resize(lastRow - 2, 1)   'Column B
    
  
            
    
    For Each i In rnggCol
        'Set rnggColRow = rnggCol.Cells(i.Row - 2).Resize(1, vColumnE.Column - 1)
        Dim strtot As String, strlve As String, _
            strday As String, streve As String, strnte As String
        Dim strampm As Double
        
        Dim myArrayd As Variant, myArrayl As Variant, myArrayampm As Variant
            myArrayd = Array("D", "D1", "D2", "D3", "D4", "G")
            myArrayl = Array("AL", "VL")
            myArrayampm = Array("AM", "PM")
            

            
            Set rng1Row = Range(Cells(1, 3), Cells(1, lastcol))
            vDayB = CDate(Format(ActiveSheet.Name, "0000-00"))
            vDayE = DateAdd("m", 1, vDayB) - 1
            Set vColumnB = rng1Row.Find(vDayB, , xlFormulas)
            Set vColumnE = rng1Row.Find(vDayE, , xlFormulas)
            
        Dim rgLookUp As Range
            Set rgLookUp = Range(i.Cells(, vColumnB.Column - 1), i.Cells(, vColumnE.Column - 1))
  
        Dim vLastRowHo As Long
        
        vLastRowHo = Worksheets("Data").Cells(Rows.Count, "A").End(xlUp).Row
        HolidayList = Worksheets("Data").Range("A2:A" & vLastRowHo).Value
        strtot = Application.NetworkDays(vDayB, vDayE, HolidayList)
        
        strampm = Application.Sum(Application.CountIfs(rgLookUp, myArrayampm)) / 2
        
                Debug.Print strampm
                          
                        
        strlve = Application.Sum(Application.Sum(Application.CountIfs(rgLookUp, myArrayl)), strampm)
                
                
        strday = Application.Sum(Application.Sum(Application.CountIfs(rgLookUp, myArrayd)), strampm)
        

        streve = Application.CountIf(rgLookUp, "E")

        strnte = Application.CountIf(rgLookUp, "N")
 
        i = "T:" & strtot & " L:" & strlve & " D:" _
            & strday & " E:" & streve & " N:" & strnte
 
    Next i
    
    'CONDITIONAL FORMATTING CELL B TO HIGHLIGHT FONT COLOR
    Dim a As Range
    Dim result As Variant
        result = Application.Sum(strlve, strday, streve, strnte)
        Debug.Print answer
      
    For Each a In rnggCol.Rows
              
        If result > strtot Then
           a.Font.Color = vbRed
    
        ElseIf result < strtot Then
           a.Font.Color = vbGreen
          
        Else: result = strtot
            a.Font.Color = vbBlack
        End If
        
      Next a
    
        
    Application.DisplayStatusBar = True
    Application.EnableEvents = True
    Application.ScreenUpdating = True

End Sub

 

[Zot]

Isn't it suppose to be
For Each a In rnggCol
instead of
For Each a In rnggCol.Rows ?

Instead of Color, use ColorIndex

 

[EXCEL MAX]

It seems works, but need to change this
HolidayList = Worksheets("Data").Range("A2:A" & vLastRowHo).value to
Set HolidayList = Worksheets("Data").Range("A2:A" & vLastRowHo)

 

[Vincent88]

It seems works, but need to change this
HolidayList = Worksheets("Data").Range("A2:A" & vLastRowHo).value to
Set HolidayList = Worksheets("Data").Range("A2:A" & vLastRowHo)

Hi EXCEL MAX,
Here is the modified version but I encounter the first day of the month error when creating a new month sheet. Is there any workaround to it ?

Sub vSum8()

    Application.DisplayStatusBar = False
    Application.EnableEvents = False
    Application.ScreenUpdating = False

    Dim rngg As Range
    Dim rnggRow As Range
    Dim i As Range
    Dim lastRow As Long
    Dim lastcol As Long
    Dim rnggCol As Range, rng1Row As Range
    Dim vDayB1 As Date, vDayE1 As Date
    Dim vColumnB1 As Range, vColumnE1 As Range

    ActiveWindow.ScrollColumn = 2
    
    lastRow = Cells(Rows.Count, "A").End(xlUp).Row
    lastcol = Cells(1, Columns.Count).End(xlToLeft).Column
    Set rngg = Range(Cells(1, 1), Cells(lastRow, lastcol))
    Set rnggCol = rngg.Columns(2).Cells(3).Resize(lastRow - 2, 1)   'Column B
    
   For Each i In rnggCol
        'Set rnggColRow = rnggCol.Cells(i.Row - 2).Resize(1, vColumnE.Column - 1)
        Dim strtot As String, strlve As String, _
            strday As String, streve As String, strnte As String
        Dim strampm As Double
        
        Dim myArrayd As Variant, myArrayl As Variant, myArrayampm As Variant
            myArrayd = Array("D", "D1", "D2", "D3", "D4", "G")
            myArrayl = Array("AL", "VL")
            myArrayampm = Array("AM", "PM")
     
            Set rng1Row = Range(Cells(1, 3), Cells(1, lastcol))
            vDayB1 = CDate(Format(ActiveSheet.Name, "0000-00"))
            vDayE1 = DateAdd("m", 1, vDayB1) - 1
            Set vColumnB1 = rng1Row.Find(vDayB1, , xlFormulas)
            Set vColumnE1 = rng1Row.Find(vDayE1, , xlFormulas)
          
            
        Dim rgLookUp As Range
            Set rgLookUp = Range(i.Cells(, vColumnB1.Column - 1), i.Cells(, vColumnE1.Column - 1))
  
        Dim vLastRowHo As Long
        
        vLastRowHo = Worksheets("Data").Cells(Rows.Count, "A").End(xlUp).Row
        'HolidayList = Worksheets("Data").Range("A2:A" & vLastRowHo).Value
        Set HolidayList = Worksheets("Data").Range("A2:A" & vLastRowHo)
        strtot = Application.NetworkDays(vDayB, vDayE, HolidayList)
        
        strampm = Application.Sum(Application.CountIfs(rgLookUp, myArrayampm)) / 2
        
                Debug.Print strampm
                   
        strlve = Application.Sum(Application.Sum(Application.CountIfs(rgLookUp, myArrayl)), strampm)
         
        strday = Application.Sum(Application.Sum(Application.CountIfs(rgLookUp, myArrayd)), strampm)
        
        streve = Application.CountIf(rgLookUp, "E")

        strnte = Application.CountIf(rgLookUp, "N")
 
        i = "T:" & strtot & " L:" & strlve & " D:" _
            & strday & " E:" & streve & " N:" & strnte
            
      'CONDITIONAL FORMATTING CELL B TO HIGHLIGHT FONT COLOR
        Dim result1 As Variant, result2 As Variant
            result1 = strtot - strlve
            result2 = Application.Sum(strday, streve, strnte)
            
            Debug.Print result1, result2
            
        If result1 = result2 Then
            i.Font.Color = vbBlack
            
        ElseIf result1 > result2 Then
            i.Font.Color = RGB(0, 184, 0)
            
        Else
            i.Font.Color = vbRed
        End If
 
     Next i
        
    Application.DisplayStatusBar = True
    Application.EnableEvents = True
    Application.ScreenUpdating = True

End Sub

 

[Vincent88]

Hi, Is it possible to temporarily stop this event when running the duplicating sheet event !

 

[EXCEL MAX]

I have replace "vSum8" procedure in your workbook with this new procedure.
After that I have with double click on the cell A1 made a sheet for new month.
In the end I have start this new procedure, and there is no error in this line.
It must be you mess something.