VBA Code Needed..using Concatenate & Compare Duplicates

Hello naven_ng,

Welcome to the Forum!

The following macro has been added to the attached workbook. The table on "Sheet1" has been copied to "Sheet2". A button on "Sheet2" will run the macro and modify the "Sheet2" table. You can change the worksheet and the starting range (first cell below the header) if you need to in the macro. These have been marked in bold text.

' Thread:  http://www.excelforum.com/excel-programming/796912-vba-code-needed-using-concatenate-and-compare-duplicates.html
' Poster:  naven_sg
' Written: October 17, 2011
' Author:  Leith Ross

Sub RemoveDuplicates()

    Dim C As Long
    Dim Cell As Range
    Dim FirstColumn As Long
    Dim IdTracks As Variant
    Dim LastColumn As Long
    Dim N As Long
    Dim Rng As Range
    Dim RngEnd As Range
    Dim Uniques As Collection
    Dim Wks As Worksheet
    
        Set Wks = Worksheets("Sheet2")
        Set Rng = Wks.Range("A5")
        
            Set RngEnd = Wks.Cells(Rows.Count, Rng.Column).End(xlUp)
            If RngEnd.Row < Rng.Row Then Exit Sub Else Set Rng = Wks.Range(Rng, RngEnd)
            
            LastColumn = Rng.End(xlToRight).Column
            Set Rng = Rng.Resize(ColumnSize:=LastColumn - Rng.Column + 1)
            
                For Each Cell In Rng
                
                    N = 0
                    Set Uniques = New Collection
                    ReDim IdTracks(Rng.Columns.Count - 1)
                    
                    For C = Rng.Column To LastColumn - Rng.Column + 1 Step 2
                        On Error Resume Next
                        Uniques.Add N, Cell.Offset(0, C) & Cell.Offset(0, C + 1)
                        
                        If Err = 0 Then
                           IdTracks(N) = Cell.Offset(0, C).Value
                           IdTracks(N + 1) = Cell.Offset(0, C + 1).Value
                           N = N + 2
                        End If
                        
                        On Error GoTo 0
                    Next C
                    
                    If N > 0 Then
                       With Cell.Offset(0, 1).Resize(1, LastColumn - Rng.Column + 1)
                            .ClearContents
                            .Value = IdTracks
                       End With
                    End If
                    
                Next Cell
               
End Sub

Hello naven_sg,

I updated the macro. There is one significant change to the worksheet. A new column was added "C". This column contains no data and is hidden. The reason for this was to maintain groups of three cells across. Here is the updated macro that has been added to the attached workbook.

' Thread:  http://www.excelforum.com/excel-programming/796912-vba-code-needed-using-concatenate-and-compare-duplicates.html
' Poster:  naven_sg
' Written: October 17, 2011
' Updated: October 21, 2011
' Author:  Leith Ross

Sub RemoveDuplicates()

    Dim C As Long
    Dim Cell As Range
    Dim FirstColumn As Long
    Dim IdTracks As Variant
    Dim LastColumn As Long
    Dim N As Long
    Dim Rng As Range
    Dim RngEnd As Range
    Dim Uniques As Collection
    Dim Wks As Worksheet
    
        Set Wks = Worksheets("Sheet2")
        Set Rng = Wks.Range("A5")
        
            Set RngEnd = Wks.Cells(Rows.Count, Rng.Column).End(xlUp)
            If RngEnd.Row < Rng.Row Then Exit Sub Else Set Rng = Wks.Range(Rng, RngEnd)
            
            LastColumn = Wks.Cells(Rng.Row - 1, Columns.Count).End(xlToLeft).Column
            Set Rng = Rng.Resize(ColumnSize:=LastColumn - Rng.Column + 1)
            
                For Each Cell In Rng.Columns(1).Cells
                
                    N = 0
                    Set Uniques = New Collection
                    ReDim IdTracks(Rng.Columns.Count - 1)
                    
                    For C = Rng.Column - 1 To LastColumn - Rng.Column Step 3
                      ' Test if name has been saved
                        On Error Resume Next
                        
                      ' Create the name by concatenating the data in 3 consecutive columns
                        Uniques.Add N, Cell.Offset(0, C + 0) & Cell.Offset(0, C + 1) & Cell.Offset(0, C + 2)
                        
                      ' Load the array with unique data
                        If Err = 0 Then
                           IdTracks(N + 0) = Cell.Offset(0, C + 0).Value
                           IdTracks(N + 1) = Cell.Offset(0, C + 1).Value
                           IdTracks(N + 2) = Cell.Offset(0, C + 2).Value
                           N = N + 3
                        End If
                        
                        On Error GoTo 0
                    Next C
                    
                  ' Copy the unique data to the row
                    If N > 0 Then
                       With Cell.Resize(1, LastColumn - Rng.Column + 1)
                            .ClearContents
                            .Value = IdTracks
                       End With
                    End If
                    
                Next Cell
               
End Sub