CODEWITHSUNDEEP
excelvba
Kish
Kish

Reputation: 89

Conditional Formatting in VBA

I am tying to manage duplicates on an Excel sheet by having the duplicate cells turn red. I put this in a use to sheet protection to keep from editing the conditional formatting for these columns. However, when I move the cell information (by clicking and dragging) the conditional formatting moves from that cell as well. At the end of the day, I do not have duplicate coverage for every cell that I want. Is there some way I can prevent this from happening when I move the cell, or what macro can I put in to take care of this?

I want to do something like this using VBA:

Sub Duplicate()
Dim rngData As Range
Dim cell As Range

Set rngData = Range("P3:P19, P56:P58, P39:P42, P21:P25, P27:P37, P39:P42, P39:P42, P44:P54, M25:M76, B69:B77, B66:E67, B51:B64, H44:H47, D44:D47, H42, H33:H40, D33:D42, H31, D28:D31, H28:H29, D5:D8" & Cells(Rows.Count, "B").End(xlUp).Row)
For Each cell In rngData
cell.Offset(0, 0).Font.Color = vbBlack          ' DEFAULT COLOR
' LOCATE DUPLICATE VALUE(S) IN THE SPECIFIED RANGE OF DATA.
        If Application.Evaluate("COUNTIF(" & rngData.Address & "," & cell.Address & ")") > 1 Then
            cell.Offset(0, 0).Font.Color = vbRed        ' CHANGE FONT COLOR TO RED.
        End If
    Next cell

    Set rngData = Nothing

    Application.ScreenUpdating = True
End Sub

But I get a "Type Mismatch" error at: If Application.Evaluate("COUNTIF(" & rngData.Address & "," & cell.Address & ")") > 1 Then

How can I get around this?

Upvotes: 0

Views: 163

Answers (1)

Scott Craner
Scott Craner

Reputation: 152450

As per comment you would need to loop twice:

Sub Duplicate()
Dim rngData As Range
Dim cell As Range
Dim cell2 As Range

Set rngData = Range("P3:P19, P56:P58, P39:P42, P21:P25, P27:P37, P39:P42, P39:P42, P44:P54, M25:M76, B69:B77, B66:E67, B51:B64, H44:H47, D44:D47, H42, H33:H40, D33:D42, H31, D28:D31, H28:H29, D5:D8" & Cells(Rows.Count, "B").End(xlUp).Row)

rngData.Font.Color = vbBlack

For Each cell In rngData
    If cell.Font.Color = vbBlack Then
        For Each cell2 In rngData
            If cell = cell2 And cell.Address <> cell2.Address Then
                cell.Font.Color = vbRed
                cell2.Font.Color = vbRed
            End If
        Next
    End If
Next


Set rngData = Nothing

Application.ScreenUpdating = True
End Sub

Upvotes: 1

Related Questions