Remove Duplicates by Row

[Guzzlr]

Hello All
I have the below code which is working good t remove duplicates by columns. I'm having issues trying to modify it to remove duplicates by Row, instead of columns.
I tried simply removing the "Column" part, and replacing with "Row"...but that was a catastrophe.
Is it possible to modify the below code to remove duplicates by row instead of columns?
Thank you

Sub RemoveDuplicate()

Application.ScreenUpdating = True
Application.DisplayAlerts = False

  For i = 1 To Sheets("Matrix").Cells.Find("*", , xlValues, , xlByColumns, xlPrevious).Column
    Sheets("Matrix").Columns(i).RemoveDuplicates Columns:=1, Header:=xlYes
  Next


Application.ScreenUpdating = False
Application.DisplayAlerts = True

 

[Logit]

Try this :

Sub remove()
Dim a As Long
For a = Cells(Rows.Count, 1).End(xlUp).Row To 1 Step -1
If WorksheetFunction.CountIf(Range("A1:A" & a), Cells(a, 1)) > 1 Then Rows(a).Delete
Next
End Sub

 

[Guzzlr]

Try this :

Sub remove()
Dim a As Long
For a = Cells(Rows.Count, 1).End(xlUp).Row To 1 Step -1
If WorksheetFunction.CountIf(Range("A1:A" & a), Cells(a, 1)) > 1 Then Rows(a).Delete
Next
End Sub

E	F	G
WIB-F	1137-A	1136-B
WIB-E	1242F-A
WIB-D	1821-F
WIB-C	24010B-A
WIB-A	6367S-B
95338S-A	WIB-C
	WIB-D
	WIB-E
	WIB-F

So lets say I have this in Columns E, F, G.
There are duplicates, How can the program search the sheet and find the duplicates, and only leave:

WIB-F

WIB-E

WIB-D

WIB-C

WIB-A

95338S-A

1137-A

1242F-A

1821-F

24010B-A

6367S-B

1136-B

The above is what would be returned, all duplicates removed, and only leaving data

 

[Logit]

Well ... that provides a lot more information to better understand your needs. See if this works for you :

Option Explicit

Sub DeleteDupsInRows()
    
    
    Dim DataRow As Variant
    Dim Dict    As Object
    Dim j       As Long
    Dim k       As Long
    Dim Key     As String
    Dim lastCol As Long
    Dim lastRow As Long
    Dim Rng     As Range
    Dim Wks     As Worksheet
    
    Set Wks = ActiveSheet
    
    Set Rng = Wks.Range("A1")
    
    lastCol = Wks.Cells.Find("*", , xlValues, xlWhole, xlByColumns, xlPrevious, False, False, False).Column
    lastRow = Wks.Cells.Find("*", , xlValues, xlWhole, xlByRows, xlPrevious, False, False, False).Row
    
    If lastRow < Rng.Row Then Exit Sub
    
    Set Rng = Rng.Resize(lastRow - Rng.Row + 1, lastCol - Rng.Column + 1)
    
    Set Dict = CreateObject("Scripting.Dictionary")
    Dict.CompareMode = vbTextCompare
    
    For j = 1 To Rng.Rows.Count
        DataRow = Rng.Rows(j).Value
        For k = 1 To UBound(DataRow, 2)
            Key = Trim(DataRow(1, k))
            If Key <> "" Then
                If Not Dict.Exists(Key) Then
                    Dict.Add Key, 1
                End If
            End If
        Next k
        Rng.Rows(j).Value = Empty
        Rng.Rows(j).Resize(1, Dict.Count).Value = Dict.Keys
        Dict.RemoveAll
    Next j
    
    Dim i As Long
    Application.ScreenUpdating = False
    With Range("A2:AV5000")
           For i = .Count To 1 Step -1
                 If .Cells(i) = "" Then .Cells(i).Delete Shift:=xlToLeft
       Next i
    End With
    Application.ScreenUpdating = True
    
End Sub

 

[Guzzlr]

Well ... that provides a lot more information to better understand your needs. See if this works for you :

Option Explicit

Sub DeleteDupsInRows()
   
   
    Dim DataRow As Variant
    Dim Dict    As Object
    Dim j       As Long
    Dim k       As Long
    Dim Key     As String
    Dim lastCol As Long
    Dim lastRow As Long
    Dim Rng     As Range
    Dim Wks     As Worksheet
   
    Set Wks = ActiveSheet
   
    Set Rng = Wks.Range("A1")
   
    lastCol = Wks.Cells.Find("*", , xlValues, xlWhole, xlByColumns, xlPrevious, False, False, False).Column
    lastRow = Wks.Cells.Find("*", , xlValues, xlWhole, xlByRows, xlPrevious, False, False, False).Row
   
    If lastRow < Rng.Row Then Exit Sub
   
    Set Rng = Rng.Resize(lastRow - Rng.Row + 1, lastCol - Rng.Column + 1)
   
    Set Dict = CreateObject("Scripting.Dictionary")
    Dict.CompareMode = vbTextCompare
   
    For j = 1 To Rng.Rows.Count
        DataRow = Rng.Rows(j).Value
        For k = 1 To UBound(DataRow, 2)
            Key = Trim(DataRow(1, k))
            If Key <> "" Then
                If Not Dict.Exists(Key) Then
                    Dict.Add Key, 1
                End If
            End If
        Next k
        Rng.Rows(j).Value = Empty
        Rng.Rows(j).Resize(1, Dict.Count).Value = Dict.Keys
        Dict.RemoveAll
    Next j
   
    Dim i As Long
    Application.ScreenUpdating = False
    With Range("A2:AV5000")
           For i = .Count To 1 Step -1
                 If .Cells(i) = "" Then .Cells(i).Delete Shift:=xlToLeft
       Next i
    End With
    Application.ScreenUpdating = True
   
End Sub

I tried the numbers in column/Row:

G:4	H:4	I:4
1	1	1
2	2	2
3	3	3
1
2
3

I'm getting an error: Application-defined or object defined error,
At: Rng.Rows(j).Resize(1, Dict.Count).Value = Dict.Keys

Thanks for the help

 

[Logit]

Do you have the following selected in the REFERENCES under TOOLS ?

 

[Guzzlr]

Do you have the following selected in the REFERENCES under TOOLS ?

I believe so:

 

[Logit]

Please post your workbook for download on a cloud site like DopBox.com or similar.

 

[Logit]

Also, in them meantime, try these two macros :

Sub AmalgamateCols()

    Dim Col As Long
    Application.ScreenUpdating = False
  
    For Col = 1 To 39     '<--- adjust number of columns here
        Range("A" & Rows.Count).End(xlUp).Offset(1).Resize(2644).Value = _
            Range(Cells(1, Col), Cells(2648, Col)).Value
    Next Col
    With Range("A1", Range("A" & Rows.Count).End(xlUp))
        .Replace 0, ""
        .Sort Key1:=Range("A1"), Order1:=xlAscending, Header:=xlNo
    End With
    Application.ScreenUpdating = True
    DeleteDups
    
End Sub

Sub DeleteDups()
    
    Dim x               As Long
    Dim LastRow         As Long
    Dim Cells           As Range
    Application.ScreenUpdating = False
    With ActiveSheet
        LastRow = .Cells(.Rows.Count, "A").End(xlUp).Row
        LastRow = LastRow
    End With
 
    For x = LastRow To 1 Step -1
        If Application.WorksheetFunction.CountIf(Range("A1:A" & x), Range("A" & x).Text) > 1 Then
            Range("A" & x).Delete
        End If
    Next x
    Application.ScreenUpdating = True
  
End Sub

 

[Guzzlr]

Also, in them meantime, try these two macros :

Sub AmalgamateCols()

    Dim Col As Long
    Application.ScreenUpdating = False
 
    For Col = 1 To 39     '<--- adjust number of columns here
        Range("A" & Rows.Count).End(xlUp).Offset(1).Resize(2644).Value = _
            Range(Cells(1, Col), Cells(2648, Col)).Value
    Next Col
    With Range("A1", Range("A" & Rows.Count).End(xlUp))
        .Replace 0, ""
        .Sort Key1:=Range("A1"), Order1:=xlAscending, Header:=xlNo
    End With
    Application.ScreenUpdating = True
    DeleteDups
   
End Sub

Sub DeleteDups()
   
    Dim x               As Long
    Dim LastRow         As Long
    Dim Cells           As Range
    Application.ScreenUpdating = False
    With ActiveSheet
        LastRow = .Cells(.Rows.Count, "A").End(xlUp).Row
        LastRow = LastRow
    End With
 
    For x = LastRow To 1 Step -1
        If Application.WorksheetFunction.CountIf(Range("A1:A" & x), Range("A" & x).Text) > 1 Then
            Range("A" & x).Delete
        End If
    Next x
    Application.ScreenUpdating = True
 
End Sub

Sub AmalgamateCols()

    Dim Col As Long
    Application.ScreenUpdating = False
 
    For Col = 1 To 39     '<--- adjust number of columns here
        Range("A" & Rows.Count).End(xlUp).Offset(1).Resize(2644).Value = _
            Range(Cells(1, Col), Cells(2648, Col)).Value
    Next Col
    With Range("A1", Range("A" & Rows.Count).End(xlUp))
        .Replace 0, ""
        .Sort Key1:=Range("A1"), Order1:=xlAscending, Header:=xlNo
    End With
    Application.ScreenUpdating = True
    DeleteDups
    
End Sub

So this one is odd.
When I paced the data set with duplicates, and run the program, it keeps the data set with duplicates, and puts them all in cell A1 in order.
This would actually be nice, if it removed the duplicates in A1 that it places them, and keeps the original data set in the body of the sheet.
It almost does this, only the data in A1 still has some duplicates.