VBA Change cell colur for duplicateds 2 conditions over lapping

[Dave8899]

Hi I need/want a VBA for conditional formatting that triggers every time the Sheet is Selected

column F has Serial Number running from “F5:F30000”, I need if possible, to have.

1. Blank cells to stay White
2. If the same ser no is entered in to F5:F2000 the cell to go red,
3. If a Ser no is entered between F5:F30000 the cell goes amber.

So if the number is in the first 2000 of the list is turns Red, if anywhere in the list other than the First 2000 it goes Amber.

I have added as normal conditional formatting but as the data is copied and pasted into the list the formatting is wiped, I have also tried Recording as a macro but it fails run. I can get it to work for 1 or the other using the code below.

Sub FormatDuplicate()

Range("F5:F2000").Select

    With Selection
        
        .FormatConditions.AddUniqueValues
        .FormatConditions(1).DupeUnique = xlDuplicate
        .FormatConditions(1).Interior.Color = RGB(255, 0, 0)
    End With
End Sub

 

[rlv01]

Perhaps something like this.

Sub FormatDuplicate()
    
    Dim FCRange1 As Range
    Dim FCRange2 As Range
    Dim TmpStr As String, S As String
    
    With ActiveSheet
        Set FCRange1 = .Range("F5:F2000")
        Set FCRange2 = .Range("F5:F30000")
    End With
    
    FCRange1.FormatConditions.Delete
    FCRange2.FormatConditions.Delete
    
    With FCRange1
        With .FormatConditions.AddUniqueValues
            .DupeUnique = xlDuplicate
            .Interior.Color = vbRed
            With .Font
                .Bold = True
                .Color = vbWhite
            End With
        End With
    End With
    
    With FCRange2
        S = .Range("A1").Address(False, False)
        TmpStr = "=LEN(TRIM(" & S & "))<>0"
        With .FormatConditions.Add(Type:=xlExpression, Formula1:=TmpStr)
            With .Interior
                .PatternColorIndex = xlAutomatic
                .Color = 49407 'change color to suit
            End With
        End With
    End With
End Sub

 

[Dave8899]

Hi that realy helpfull thank you. one thing i did not explin but i have used your code to solve, was any cell without a duplicate needed to be White also, below is you coded with the slight amendmnet.

thank you very mush it was driving me crazy.

Sub FormatDuplicate()
   
    Dim FCRange1 As Range
    Dim FCRange2 As Range
    Dim TmpStr As String, S As String
   
    With ActiveSheet
        Set FCRange1 = .Range("F5:F2000")
        Set FCRange2 = .Range("F5:F30000")
    End With
   
    FCRange1.FormatConditions.Delete
    FCRange2.FormatConditions.Delete
   
    With FCRange1
        With .FormatConditions.AddUniqueValues
            .DupeUnique = xlDuplicate
            .Interior.Color = vbRed 'change color to suit
            With .Font
                .Color = vbBlack 'change color to suit
            End With
        End With
    End With
   
    With FCRange2
       With .FormatConditions.AddUniqueValues
            .DupeUnique = xlDuplicate
            .Interior.Color = RGB(255, 194, 0) 'change color to suit
            With .Font
                .Color = vbBlack 'change color to suit
              End With
        End With
     End With
   
   With FCRange2
        S = .Range("A1").Address(False, False)
        TmpStr = "=LEN(TRIM(" & S & "))<>0"
        With .FormatConditions.Add(Type:=xlExpression, Formula1:=TmpStr)
            With .Interior
                .PatternColorIndex = xlAutomatic
                .Color = vbWhite 'change color to suit
            End With
        End With
     End With
   
   
   
End Sub

 

[rlv01]

I'm glad it worked for you.