Posts by roy__lam

  • Count Merged Cells Based on background color and value

    Hi Bro, I have a code below which can count number of cell based on cell background color even in merged cells:


    Function ColorBlocks(SearchRange As range, ColorRange As range, Optional Sum As Boolean = False) As Double
    Dim cell As range, blocks As range
    If Sum Then
    Set blocks = SearchRange(1).MergeArea(1) ' prime union method (which requires >1 value)
    For Each cell In SearchRange
    If cell.Interior.Color = ColorRange.Interior.Color Then Set blocks = Union(blocks, cell.MergeArea(1))
    Next
    If SearchRange(1).Interior.Color <> ColorRange.Interior.Color Then
    ColorBlocks = WorksheetFunction.Sum(blocks) - SearchRange(1).MergeArea(1).Value
    Else
    ColorBlocks = WorksheetFunction.Sum(blocks)
    End If
    Else
    Set blocks = SearchRange(1).MergeArea(1) ' prime union method (which requires >1 value)
    For Each cell In SearchRange
    If cell.Interior.Color = ColorRange.Interior.Color Then Set blocks = Union(blocks, cell.MergeArea(1))
    Next
    ColorBlocks = blocks.Count + (SearchRange(1).Interior.Color <> ColorRange.Interior.Color)
    End If
    End Function



    then I modify the code to let it counting colored cell AND matching cell value as follows:



    Function ColorBlocks(SearchRange As range, ColorRange As range, Optional Sum As Boolean = False) As Double
    Dim cell As range, blocks As range
    If Sum Then
    Set blocks = SearchRange(1).MergeArea(1) ' prime union method (which requires >1 value)
    For Each cell In SearchRange
    If cell.Interior.Color = ColorRange.Interior.Color And cell.Value = ColorRange.Value Then Set blocks = Union(blocks, cell.MergeArea(1))
    Next
    If SearchRange(1).Interior.Color <> ColorRange.Interior.Color Then
    ColorBlocks = WorksheetFunction.Sum(blocks) - SearchRange(1).MergeArea(1).Value
    Else
    ColorBlocks = WorksheetFunction.Sum(blocks)
    End If
    Else
    Set blocks = SearchRange(1).MergeArea(1) ' prime union method (which requires >1 value)
    For Each cell In SearchRange
    If cell.Interior.Color = ColorRange.Interior.Color And cell.Value = ColorRange.Value Then Set blocks = Union(blocks, cell.MergeArea(1))
    Next
    ColorBlocks = blocks.Count + (SearchRange(1).Interior.Color <> ColorRange.Interior.Color)
    End If
    End Function


    But the retured result was 1 more than actual, so please help to fix it.