Help With Replicating VBA?

[Argent-4]

I'm finishing up a pedigree database of sorts that I've been working on as a personal project, and I need a way to highlight duplicate values. I know conditional formatting can be used to identify duplicates, but I need each duplicated value to be a different color. The goal:

I found a VBA code that properly colors duplicates, but I'm having issues translating it into my own workbook. Besides the issue with the VBA being written in Polish, it seems the author has created ranges I cannot find and/or have no access to (rngDoPokolorowania, Licznik, and others), and therefore cannot replicate.


How to find and color duplicate values with Excel and VBA » Marcin's Excel Tips

Option Explicit


Private Sub Worksheet_Change(ByVal Target As Range)


Dim rngKolory As Range
Dim rngDoPokolorowania As Range
Dim LicznikKolorow As Integer
Dim Licznik As Integer
Dim rngKolumna As Range
Dim rngDaneWypelnione As Range


' cells with colors to choose from
Set rngKolory = wksKolory.Range("rngKoloryStart").Resize(wksKolory.Range("settIleKolorow").Value, 1)
' cells with data to be "colored"
Set rngDoPokolorowania = wksDane.Range(Range("rngDaneStart"), Cells(65535, Range("rngDaneStart").Column).End(xlUp))


' column with data
Set rngKolumna = Columns("B")


With wksDane
    Set rngDaneWypelnione = .Range(.Range("rngDaneStart"), .Range("rngDaneStart").Offset(10000).End(xlUp))
End With


If Not Intersect(Target, rngKolumna) Is Nothing Then


Application.ScreenUpdating = False '


' Let's clear the whole data area (set background color to default)


rngDaneWypelnione.Resize(rngDaneWypelnione.Count + 1).Interior.ColorIndex = _
    wksKolory.Range("rngDomyslneTlo").Interior.ColorIndex


LicznikKolorow = 1 ' color counter reset


With rngDoPokolorowania
   ' first cell
   If Application.WorksheetFunction.CountIf(rngDoPokolorowania, .Cells(1).Value) > 1 Then
      .Cells(1).Interior.ColorIndex = rngKolory.Cells(LicznikKolorow).Interior.ColorIndex
      LicznikKolorow = LicznikKolorow + 1
      If LicznikKolorow > rngKolory.Count Then LicznikKolorow = 1
   End If
    
    'more than one cell
    If rngDaneWypelnione.Count > 1 Then
        ' for following cells
        For Licznik = 2 To .Count
            If Application.WorksheetFunction.CountIf(rngDoPokolorowania, _
                                                    .Cells(Licznik).Value) > 1 Then
                If Application.WorksheetFunction.CountIf(Range("rngDaneStart").Resize(Licznik - 1), .Cells(Licznik).Value) > 0 Then
                    .Cells(Licznik).Interior.ColorIndex = _
                    rngDaneWypelnione.Find(what:=.Cells(Licznik).Value, after:=.Cells(Licznik), SearchDirection:=xlPrevious, lookat:=xlWhole).Interior.ColorIndex
                Else
                    .Cells(Licznik).Interior.ColorIndex = rngKolory.Cells(LicznikKolorow).Interior.ColorIndex
                    LicznikKolorow = LicznikKolorow + 1
                If LicznikKolorow > rngKolory.Count Then LicznikKolorow = 1
                End If
            End If
       Next Licznik
    End If
End With
Application.ScreenUpdating = True
End If
   
End Sub

Would anyone be willing to help me figure out Marcin's VBA, or perhaps provide an alternative?

 

[Boswell]

I did not attempt to read the polish code; however, I think the below will be a good start. I didn't test thoroughly for corner cases - so review and tweak to make sure it works for your situation. Additionally, I set this up as an event because the previous code did so.. but this would probably be better set as a macro linked to a button to avoid calculation lag.

Private Sub Worksheet_Change(ByVal Target As Range)

    ' get range of interest and create array to store duplicated values
    Dim dbRange As Range: Set dbRange = Me.Range("B1:D10")
    ReDim duplicates(1 To 1) As Variant
        
    ' clear conditional formatting from range
    dbRange.FormatConditions.Delete
    
    Dim c As Range
    Dim duplicantCount As Integer: duplicantCount = 0
    
    ' loop through and find all duplicates
    For Each c In dbRange.Cells
    
        ' if cell is not blank
        If (Len(c.Value) > 0) Then
        
            ' if cells is a duplicate
            If (Application.WorksheetFunction.CountIf(dbRange, c.Value) > 1) Then
            
                ' if this is the first occurence of the duplicate
                If Not varArrayContains(duplicates, c.Value) Then
                    
                    ' add to duplicate array
                    duplicantCount = duplicantCount + 1
                    ReDim Preserve duplicates(1 To duplicantCount)
                    duplicates(duplicantCount) = c.Value
                    
                End If
                
            End If
            
        End If
    Next
    
    ' conditional format dbRange according to the duplicate values
    Dim i As Integer
    For i = LBound(duplicates) To UBound(duplicates)
        Call applyConditionalFormats(dbRange, duplicates(i), 20 + i)
    Next
    
    
        
End Sub

' maybe a built in way to do this ... but this seemed easy enough
Private Function varArrayContains(inArray() As Variant, inValue As Variant) As Boolean
    
    Dim i As Integer
    For i = LBound(inArray) To UBound(inArray)
        If inArray(i) = inValue Then
            varArrayContains = True
            Exit Function
        End If
    Next
    
    varArrayContains = False
    
End Function

' made this a sub for convenience
Private Sub applyConditionalFormats(inRange As Range, inValue As Variant, inColorIndex As Integer)

    With inRange
    
        .FormatConditions.Add Type:=xlCellValue, Operator:=xlEqual, Formula1:=inValue
        With .FormatConditions(.FormatConditions.Count).Interior
            .ColorIndex = inColorIndex
        End With
        
    End With
    
End Sub

 

[Argent-4]

Thank you for your time.

The code is working beautifully so far. Could you tell me what to add so that the cell value "unknown" that is not color coded when it is duplicated? Also, how do I specify the color options for the formatting?

 

[Boswell]

If I understand your first question correctly, you are saying that in your database range you have multiple cells with the string "unknown" as their value and you want to exclude those cells from being color coded. If I am interpreting that correctly - then that can be accomplished by adding an if statement that checks if c.value is equal to "unknown"... similar to below:

        ' if cell is not blank
        If (Len(c.Value) > 0) Then
            If Not (UCase(c.Value) = "UNKNOWN") Then '<- this if statement excludes values equal to 'unknown'
                ' if cells is a duplicate
                If (Application.WorksheetFunction.CountIf(dbRange, c.Value) > 1) Then
                
                    ' if this is the first occurence of the duplicate
                    If Not varArrayContains(duplicates, c.Value) Then
                        
                        ' add to duplicate array
                        duplicantCount = duplicantCount + 1
                        ReDim Preserve duplicates(1 To duplicantCount)
                        duplicates(duplicantCount) = c.Value
                        
                    End If
                    
                End If
            End If
        End If

As far as color options for the formatting - I used the ColorIndex property. Notice that the function 'applyConditionalFormats' has an argument 'inColorIndex' and i am passing in the integer 20 + i where the i corresponds to the index of the duplicates array. I used this approach because it ensures each duplicate will have a different color... I added 20 to i because It produced better colors (IMO). You could definitely come up with a more sophisticated way of generating the formats - but would need to be careful that you have enough unique colors to go with each set of duplicates.

 

[Argent-4]

That's exactly what I needed. I think I've managed to properly adjust the code so that it runs when a button is clicked, instead of automatically. Still working on the custom color palette/index.

Thanks again for the help.