VBA for multi level conditional formatting

[ajl344]

Hi all,

I'm running into a logic mental block on something I'm working on.

I am trying to do 2 things:
1. Highlight any duplicates in column B (starting from row 3)
2. For each 'set' of duplicates in column B, check if column E has any duplicate values (different values to column B)

eg, column B value is "1" and is duplicated elsewhere in column B -> highlight duplicate values in Column E but only if column B =1. Rinse and repeat for other duplicates in column B.

Any help will be greatly appreciated.

Sub HighlightDuplicates()

    'Declare All Variables
    Dim r As Range, rB As Range
    Dim ws As Worksheet
    Dim i As Long
    
    'Clear previous highlighting
    Worksheets("ProjectData").Cells.Interior.Pattern = xlNone

    'Set target worksheet
    Set ws = ThisWorkbook.Sheets("ProjectData")
    
    'Find dupliates in coumn B and highlight amber
    i = ws.Range("B" & Rows.Count).End(xlUp).Row
    Set rB = ws.Range("B3:B" & i)

    For Each r In rB
        If WorksheetFunction.CountIf(rB, r.Value) > 1 Then
        r.Interior.ColorIndex = 44
        End If
    Next
    
    'For each row set of duplicates in column B, check column E for duplicates and highlight red (ColorIndex =3)
    
End Sub

 

[ajl344]

Hi all,

I'm running into a logic mental block on something I'm working on.

I am trying to do 2 things:
1. Highlight any duplicates in column B (starting from row 3)
2. For each 'set' of duplicates in column B, check if column E has any duplicate values (different values to column B)

eg, column B value is "1" and is duplicated elsewhere in column B -> highlight duplicate values in Column E but only if column B =1. Rinse and repeat for other duplicates in column B.

Any help will be greatly appreciated.

Sub HighlightDuplicates()

    'Declare All Variables
    Dim r As Range, rB As Range
    Dim ws As Worksheet
    Dim i As Long
   
    'Clear previous highlighting
    Worksheets("ProjectData").Cells.Interior.Pattern = xlNone

    'Set target worksheet
    Set ws = ThisWorkbook.Sheets("ProjectData")
   
    'Find dupliates in coumn B and highlight amber
    i = ws.Range("B" & Rows.Count).End(xlUp).Row
    Set rB = ws.Range("B3:B" & i)

    For Each r In rB
        If WorksheetFunction.CountIf(rB, r.Value) > 1 Then
        r.Interior.ColorIndex = 44
        End If
    Next
   
    'For each row set of duplicates in column B, check column E for duplicates and highlight red (ColorIndex =3)
   
End Sub

Here is an image showing what the output should look like:

 

[BigBeachBananas]

If I understand correctly, for a set of duplicates in B, only instances after the first gets highlighted if there's an x in E.


Can you confirm?

 

[ajl344]

If I understand correctly, for a set of duplicates in B, only instances after the first gets highlighted if there's an x in E.


Can you confirm?

Hi and thanks for your assistance,

No, for any instance of a duplicate in B, highlight in E any cells that have duplicates (the x).

 

[BigBeachBananas]

Hi and thanks for your assistance,

No, for any instance of a duplicate in B, highlight in E any cells that have duplicates (the x).

You say duplicates in E, are there any other values other than x, or it's always x?

 

[ajl344]

You say duplicates in E, are there any other values other than x, or it's always x?

always x

 

[BigBeachBananas]

Sub HighlightDuplicates()
    Dim ws As Worksheet
    Dim lastRow As Long
    Dim cell As Range
    Dim currentValue As Variant
    Dim countX As Integer
   
    Set ws = ThisWorkbook.Sheets("Sheet1") '<~~Change sheet name as needed
    lastRow = ws.Cells(ws.Rows.Count, "B").End(xlUp).Row
   
    For Each cell In ws.Range("B3:B" & lastRow)
        If cell.Value = currentValue Then
            cell.Interior.ColorIndex = 44
            If cell.Offset(0, 3).Value = "x" Then
                countX = countX + 1
            End If
        Else
            If countX > 1 Then
                ws.Range(cell.Offset(-countX, 3), cell.Offset(-1, 3)).Interior.ColorIndex = 3
            End If
            currentValue = cell.Value
            countX = 0
        End If
    Next cell
End Sub

EDIT: The code works for your sample data, but probably not what was intended.

 

[bebo021999]

try below code:

Option Explicit
Sub test()
Dim lr&, i&, rng, ce As Range
Dim dic As Object
Set dic = CreateObject("Scripting.Dictionary")
lr = Cells(Rows.Count, "B").End(xlUp).Row
rng = Range("B3:E" & lr).Value
For i = 1 To UBound(rng)
    If Not dic.exists(rng(i, 1)) Then
        dic.Add rng(i, 1), 1
    Else
        dic(rng(i, 1)) = dic(rng(i, 1)) + 1
    End If
Next
For Each ce In Range("B3:B" & lr)
    If dic(ce.Value) > 1 Then ce.Interior.Color = vbYellow
    If WorksheetFunction.CountIf(Range("B3", ce), ce) > 1 And Not IsEmpty(ce.Offset(, 3)) Then
        ce.Offset(, 3).Interior.Color = vbRed
    End If
Next
End Sub

 

[ajl344]

Sub HighlightDuplicates()
    Dim ws As Worksheet
    Dim lastRow As Long
    Dim cell As Range
    Dim currentValue As Variant
    Dim countX As Integer
  
    Set ws = ThisWorkbook.Sheets("Sheet1") '<~~Change sheet name as needed
    lastRow = ws.Cells(ws.Rows.Count, "B").End(xlUp).Row
  
    For Each cell In ws.Range("B3:B" & lastRow)
        If cell.Value = currentValue Then
            cell.Interior.ColorIndex = 44
            If cell.Offset(0, 3).Value = "x" Then
                countX = countX + 1
            End If
        Else
            If countX > 1 Then
                ws.Range(cell.Offset(-countX, 3), cell.Offset(-1, 3)).Interior.ColorIndex = 3
            End If
            currentValue = cell.Value
            countX = 0
        End If
    Next cell
End Sub

EDIT: The code works for your sample data, but probably not what was intended.

Thanks for the assist, this doesn't quite do what i was looking for but i appreciate the help.

 

[ajl344]

try below code:

Option Explicit
Sub test()
Dim lr&, i&, rng, ce As Range
Dim dic As Object
Set dic = CreateObject("Scripting.Dictionary")
lr = Cells(Rows.Count, "B").End(xlUp).Row
rng = Range("B3:E" & lr).Value
For i = 1 To UBound(rng)
    If Not dic.exists(rng(i, 1)) Then
        dic.Add rng(i, 1), 1
    Else
        dic(rng(i, 1)) = dic(rng(i, 1)) + 1
    End If
Next
For Each ce In Range("B3:B" & lr)
    If dic(ce.Value) > 1 Then ce.Interior.Color = vbYellow
    If WorksheetFunction.CountIf(Range("B3", ce), ce) > 1 And Not IsEmpty(ce.Offset(, 3)) Then
        ce.Offset(, 3).Interior.Color = vbRed
    End If
Next
End Sub

Thanks Bebo, This looks like it will do what I was looking for. I'm just doing some tests now.