Consulting

Results 1 to 5 of 5

Thread: Highlight duplicate data blocks

  1. #1

    Highlight duplicate data blocks

    Hi all,


    I have a large data sheet made of 8 columns (A:H) and over 45000 rows.
    Data are sorted into sets of variable number of rows. Each set of data is separated from the following with one blank row.
    I am in need to highlight duplicate data blocks/sets. Duplicate data blocks have to be identical in everything: the number of rows per each set and data content per row and column of that data block.

    I spent a long time searching for a similar answered question, but in vain.

    Can I get some assistance with this question, please?

    More than appreciating ..

    M.

  2. #2
    VBAX Expert Leith Ross's Avatar
    Joined
    Oct 2012
    Location
    San Francisco, California
    Posts
    552
    Location
    Hello mpeterson,

    This will highlight duplicate groups on "Sheet1". Change the worksheet name in the code if your worksheet name is different. The macro starts with cell "A1". If you need to start elsewhere, the code will need to be modified a little.

    Sub HighlightDupes()
    
    
        Dim Data        As Variant
        Dim EndRow      As Long
        Dim LastEntry   As Variant
        Dim MainRng     As Range
        Dim n           As Long
        Dim Rng         As Range
        Dim Row         As Variant
        Dim Text        As String
        Dim Uniques     As New Collection
        Dim Wks         As Worksheet
        Dim xArray      As Variant
        
            Set Wks = ThisWorkbook.Worksheets("Sheet1")
            Set MainRng = Wks.UsedRange
        
            Set LastEntry = MainRng.Find("*", Range("A1"), xlValues, xlWhole, xlByRows, xlPrevious, False, False, False)
            If LastEntry Is Nothing Then Exit Sub
            
            EndRow = LastEntry.Row + 1
            
            Set MainRng = MainRng.Cells(1, 1).Resize(EndRow - MainRng.Row + 1, 8)
            Set Rng = MainRng.CurrentRegion.Resize(, 8)
            
            Do
                DoEvents
                
                Text = ""
                
                For Each Row In Rng.Rows
                    ' // Convert 2-D row into 1-D scalar array
                    xArray = Application.Transpose(Row.Value)
                    xArray = Application.Transpose(x)
            
                    ' // Convert arrays to a single string
                    Text = Text & Join(xArray, " ")
                Next Row
                
                ' // Create a key for this block
                If Len(Text) > 255 Then
                    Text = Left(Text, 255)
                End If
                
                ' // Highlight the group if it is a duplicate
                On Error Resume Next
                    Uniques.Add Item:=Rng, Key:=Text
                    If Err.Number = 457 Then
                        Rng.Interior.Color = RGB(255, 255, 0)
                    End If
                On Error GoTo 0
                
                ' // Get the next block
                Set Rng = Rng.Offset(Rng.Rows.Count + 1, 0)
                
                If Rng.Row >= EndRow Then Exit Do
                Set Rng = Rng.CurrentRegion.Resize(, 8)
            Loop
    
    
    End Sub
    Sincerely,
    Leith Ross

    "1N73LL1G3NC3 15 7H3 4B1L17Y 70 4D4P7 70 CH4NG3 - 573PH3N H4WK1NG"

  3. #3
    Hi Leith,
    You don't know how much appreciating I am for your assistance. I actually thought no one would be able to help with such question, so I do thank you for your invaluable assistance.
    As I ran the code, it halted with an error message Run-time error 13, Type mismatch. Debugging the error, it highlighted the following line in yellow:
    Text = Text & Join(xArray, " ")
    I hope it would be easy to fix.
    Once again thank you very much.

    M.

  4. #4
    Does this macro do what you want...
    Sub HighlightDupes() Dim X As Long, Z As Long, Groups As Range, Arr1 As Variant, Arr2 As Variant Set Groups = Columns("A:H").SpecialCells(xlConstants) For X = 1 To Groups.Areas.Count - 1 Arr1 = Groups.Areas(X) For Z = X + 1 To Groups.Areas.Count Arr2 = Groups.Areas(Z) If Evaluate("IFERROR(SUM(0+(" & Groups.Areas(X).Address & "=" & Groups.Areas(Z).Address & "))=counta(" & Groups.Areas(X).Address & "),FALSE)") Then Groups.Areas(X).Interior.Color = vbYellow Groups.Areas(Z).Interior.Color = vbYellow End If Next Next End Sub

  5. #5
    Yes Rothstein, it does do what I want as exactly as I want it to be.
    Honestly, I'm stunned as your code came to me out of the blue. Thank you very much for your precious assistance that came in my dire need.
    Please accept my best regards,

    M.

Tags for this Thread

Posting Permissions

  • You may not post new threads
  • You may not post replies
  • You may not post attachments
  • You may not edit your posts
  •