Macro partially working

Hi phbryan,

Let me know how this goes:

Option Explicit
Sub Macro1()

    Call MyHighlight(True) 'True to highlight where SUM > AVG, or False to highlight where SUM < AVG

End Sub
Sub MyHighlight(blnSumIsGreaterThanAvg As Boolean)

    Dim objMyArray As Object
    Dim lngLastRow As Long, lngMyRow As Long
    Dim ws As Worksheet
    Dim varItem As Variant
    Dim dblSUMValue As Double, dblAVGValue As Double
    
    Set ws = ThisWorkbook.Sheets("Sheet2") 'Sheet name containing data. Change to suit if necessary.
    Set objMyArray = CreateObject("System.Collections.ArrayList")
    
    If WorksheetFunction.CountA(ws.Cells) = 0 Then
        MsgBox "There is no data in """ & ws.Name & """ to work with.", vbExclamation
        Exit Sub
    End If
    
    Application.ScreenUpdating = False
    
    lngLastRow = ws.Range("A:C").Find("*", SearchOrder:=xlByRows, SearchDirection:=xlPrevious).Row
    
    ws.Range("A2:A" & lngLastRow).Interior.Color = xlNone 'Clear any previous highlighting
    
    'Create an unique array of items in Col. A
    For lngMyRow = 2 To lngLastRow
        If objMyArray.Contains(CStr(Trim(ws.Range("A" & lngMyRow)))) = False Then
            objMyArray.Add CStr(Trim(ws.Range("A" & lngMyRow)))
        End If
    Next lngMyRow
    
    For Each varItem In objMyArray
        dblSUMValue = Application.WorksheetFunction.SumIf(ws.Range("A2:A" & lngLastRow), varItem, ws.Range("B2:B" & lngLastRow))
        dblAVGValue = Application.WorksheetFunction.AverageIf(ws.Range("A2:A" & lngLastRow), varItem, ws.Range("C2:C" & lngLastRow))
        For lngMyRow = 2 To lngLastRow
            If Trim(ws.Range("A" & lngMyRow)) = varItem Then
                If blnSumIsGreaterThanAvg = True Then
                    If dblSUMValue > dblAVGValue Then
                        ws.Range("A" & lngMyRow).Interior.Color = RGB(255, 255, 0) 'Yellow if SUM > AVG
                    End If
                Else
                    If dblSUMValue < dblAVGValue Then
                        ws.Range("A" & lngMyRow).Interior.Color = RGB(0, 255, 0) 'Green if SUM < AVG
                    End If
                End If
            End If
        Next lngMyRow
    Next varItem
    
    Application.ScreenUpdating = True
    
End Sub

Regards,

Robert

Hey Robert,

I get a Runtime Error at this line:

Set objMyArray = CreateObject("System.Collections.ArrayList")

Thank you Artik and trebor. The macro now runs.
The macro should have highlighted A2:A6 and A9:A13, but it did not. See this most updated workbook.

Here's another (virtually same) way but uses collections:

Option Explicit
Sub Macro1()

    Call MyHighlight(False) 'True to highlight where SUM > AVG, or False to highlight where SUM < AVG

End Sub
Sub MyHighlight(blnSumIsGreaterThanAvg As Boolean)

    Dim varMyArray As New Collection
    Dim lngLastRow As Long, lngMyRow As Long
    Dim ws As Worksheet
    Dim varItem As Variant
    Dim dblSUMValue As Double, dblAVGValue As Double
    
    Set ws = ThisWorkbook.Sheets("Sheet2") 'Sheet name containing data. Change to suit if necessary.
    If WorksheetFunction.CountA(ws.Cells) = 0 Then
        MsgBox "There is no data in """ & ws.Name & """ to work with.", vbExclamation
        Exit Sub
    End If
    
    Application.ScreenUpdating = False
    
    lngLastRow = ws.Range("A:C").Find("*", SearchOrder:=xlByRows, SearchDirection:=xlPrevious).Row
    
    ws.Range("A2:A" & lngLastRow).Interior.Color = xlNone 'Clear any previous highlighting
    
    'Create an unique array of items in Col. A
    For lngMyRow = 2 To lngLastRow
        On Error Resume Next
            varMyArray.Add CStr(Trim(ws.Range("A" & lngMyRow)))
        On Error GoTo 0
    Next lngMyRow
    
    For Each varItem In varMyArray
        dblSUMValue = Application.WorksheetFunction.SumIf(ws.Range("A2:A" & lngLastRow), varItem, ws.Range("B2:B" & lngLastRow))
        dblAVGValue = Application.WorksheetFunction.AverageIf(ws.Range("A2:A" & lngLastRow), varItem, ws.Range("C2:C" & lngLastRow))
        For lngMyRow = 2 To lngLastRow
            If Trim(ws.Range("A" & lngMyRow)) = varItem Then
                If blnSumIsGreaterThanAvg = True Then
                    If dblSUMValue > dblAVGValue Then
                        ws.Range("A" & lngMyRow).Interior.Color = RGB(255, 255, 0) 'Yellow if SUM > AVG
                    End If
                Else
                    If dblSUMValue < dblAVGValue Then
                        ws.Range("A" & lngMyRow).Interior.Color = RGB(0, 255, 0) 'Green if SUM < AVG
                    End If
                End If
            End If
        Next lngMyRow
    Next varItem
    
    Application.ScreenUpdating = True
    
End Sub

Try this:

Option Explicit
Sub SUM_More_Than_Avg()

    Call MyHighlight(True, "Sheet2") 'True to highlight where SUM > AVG, or False to highlight where SUM < AVG
    
End Sub
Sub SUM_Less_Than_Avg()

    Call MyHighlight(False, "Sheet2") 'True to highlight where SUM > AVG, or False to highlight where SUM < AVG
    
End Sub
Sub MyHighlight(blnSumIsGreaterThanAvg As Boolean, strSheetName As String)

    Dim varMyArray As New Collection
    Dim lngLastRow As Long, lngMyRow As Long
    Dim ws As Worksheet
    Dim varItem As Variant
    Dim dblSUMValue As Double, dblAVGValue As Double
    
    Set ws = ThisWorkbook.Sheets(strSheetName)
    If WorksheetFunction.CountA(ws.Cells) = 0 Then
        MsgBox "There is no data in """ & ws.Name & """ to work with.", vbExclamation
        Exit Sub
    End If
    
    Application.ScreenUpdating = False
    
    lngLastRow = ws.Range("A:C").Find("*", SearchOrder:=xlByRows, SearchDirection:=xlPrevious).Row
    
    ws.Range("A2:A" & lngLastRow).Interior.Color = xlNone 'Clear any previous highlighting
    
    'Create an unique array of items in Col. A
    For lngMyRow = 2 To lngLastRow
        On Error Resume Next
            varMyArray.Add CStr(Trim(ws.Range("A" & lngMyRow)))
        On Error GoTo 0
    Next lngMyRow
    
    For Each varItem In varMyArray
        dblAVGValue = Application.WorksheetFunction.AverageIf(ws.Range("A2:A" & lngLastRow), varItem, ws.Range("C2:C" & lngLastRow))
        For lngMyRow = 2 To lngLastRow
            If Trim(ws.Range("A" & lngMyRow)) = varItem Then
                If blnSumIsGreaterThanAvg = True Then
                    If Application.WorksheetFunction.SumIf(ws.Range("A2:A" & lngLastRow), varItem, ws.Range("B2:B" & lngLastRow)) < dblAVGValue Then
                        Exit For
                    Else
                        dblSUMValue = IIf(dblSUMValue = 0, ws.Range("B" & lngMyRow), dblSUMValue + ws.Range("B" & lngMyRow))
                        ws.Range("A" & lngMyRow).Interior.Color = RGB(255, 255, 0) 'Yellow if SUM > AVG. Change to suit if necessary.
                        If dblSUMValue > dblAVGValue Then
                            Exit For
                        End If
                    End If
                ElseIf blnSumIsGreaterThanAvg = False Then
                    If Application.WorksheetFunction.SumIf(ws.Range("A2:A" & lngLastRow), varItem, ws.Range("B2:B" & lngLastRow)) > dblAVGValue Then
                        Exit For
                    Else
                        dblSUMValue = IIf(dblSUMValue = 0, ws.Range("B" & lngMyRow), dblSUMValue + ws.Range("B" & lngMyRow))
                        If dblSUMValue < dblAVGValue Then
                            ws.Range("A" & lngMyRow).Interior.Color = RGB(0, 255, 0) 'Green if SUM < AVG. Change to suit if necessary.
                        Else
                            Exit For
                        End If
                    End If
                End If
            End If
        Next lngMyRow
        dblSUMValue = 0
    Next varItem
    
    Application.ScreenUpdating = True
    
End Sub