Delete duplicate cells in row, row by row

[HowdeeDoodee]

Want to delete duplicate cells in each row

I have rows of data with duplicate cells in each row. I do not want to delete any rows. I want to delete only duplicate cells in each row.

For example, I now have in one row...

fox, sheep, goat, fox, dog, cat, fox

I want to delete the duplicate cells in each row. I want to end up with the following...

fox, sheep, goat, dog, cat

I have over 25,000 rows and over 200 columns.

Thank you in advance for any replies.

 

[sweater_vests_rock]

HowDeeDoDee.

You have a lot of data, so I can't make any promises on the speed of this solution; it isn't the worst way to do it, though.

as always, please execute macros on a copy of your file -- they cannot be undone!

hope this helps. ben.

Sub DeleteDuplicates()

Dim MyRange As Range, rw As Range
Dim MyArray() As Variant
Dim aryEntry() As String, aryFilter() As String
Dim MyFilter As String, MyIndex As Integer
Dim i As Integer

Set MyRange = ActiveSheet.UsedRange
LastColumn = MyRange.Columns.Count

ReDim aryEntry(1 To LastColumn)
ReDim aryFilter(1 To 1)

For Each rw In MyRange.Rows
    'Load row into the output array
    MyArray = rw.Cells
    
    'Combines cell values and column index in a single array index
    For i = 1 To UBound(MyArray, 2)
        aryEntry(i) = MyArray(1, i) & " " & i
    Next i

    For i = 1 To UBound(MyArray, 2)
        'Filter only on the cell value, not the index
        MyFilter = Left(aryEntry(i), InStr(1, aryEntry(i), " ") - 1)
        
        'Loads duplicate cell values (with column index) into an array
        aryFilter = Filter(aryEntry, MyFilter)
        
        'If more than one entry exists, it is a duplicate
        If UBound(aryFilter) > 0 Then
            
            'Separates index from cell value
            MyIndex = Right(aryEntry(i), Len(aryEntry(i)) - InStr(1, aryEntry(i), " "))
            
            'Clear all duplicate entries (but not original)
            For j = 1 To UBound(aryFilter)
                MyArray(1, MyIndex) = ""
            Next j
        End If
    Next i
    
    'Returns cleaned array to the worksheet
    rw.Cells = MyArray
Next rw

'Deletes all blank cells in the used range
MyRange.SpecialCells(xlCellTypeBlanks).Delete (xlShiftToLeft)

End Sub

 

[HowdeeDoodee]

Thank you, svr, I will give this a try. Very much appreciated.

 

[HowdeeDoodee]

svr or anyone else...

I just tried out this macro and I got the following error.


Run type error
Type Mismatch

The Debugger Points To The Following Line in the code.

MyIndex = Right(aryEntry(i), Len(aryEntry(i)) - InStr(1, aryEntry(i), " "))

Thank you in advance for any replies.

 

[sweater_vests_rock]

howdee.

do any of your cells have spaces in them? this will cause an error type 13.

i'll fix this asap.
ben.

 

[sweater_vests_rock]

howdee.

presuming you do not have any cases of "@@" in your dataset, this should work for you. if for some reason you do, just change

MyMarker = "@@"

to some other random symbol combination which does not occur in your dataset.

cheers. ben.

Sub DeleteDuplicates()

Dim MyRange As Range, rw As Range
Dim MyArray() As Variant
Dim aryEntry() As String, aryFilter() As String
Dim MyMarker As String, MyFilter As String, MyIndex As Integer
Dim i As Integer

'THIS VAR MUST BE UNIQUE TO YOUR DATASET
MyMarker = "@@"

Set MyRange = ActiveSheet.UsedRange
LastColumn = MyRange.Columns.Count

ReDim aryEntry(1 To LastColumn)
ReDim aryFilter(1 To 1)

For Each rw In MyRange.Rows
    'Load row into the output array
    MyArray = rw.Cells
    
    'Combines cell values and column index in a single array index
    For i = 1 To UBound(MyArray, 2)
        aryEntry(i) = MyArray(1, i) & MyMarker & i
    Next i

    For i = 1 To UBound(MyArray, 2)
        'Filter only on the cell value, not the index
        MyFilter = Left(aryEntry(i), InStr(1, aryEntry(i), MyMarker) - 1)
        
        'Loads duplicate cell values (with column index) into an array
        aryFilter = Filter(aryEntry, MyFilter)
        
        'If more than one entry exists, it is a duplicate
        If UBound(aryFilter) > 0 Then
            
            'Separates index from cell value
            MyIndex = Right(aryEntry(i), Len(aryEntry(i)) - _
                (InStr(1, aryEntry(i), MyMarker) + Len(MyMarker) - 1))
            
            'Clear all duplicate entries (but not original)
            For j = 1 To UBound(aryFilter)
                MyArray(1, MyIndex) = ""
            Next j
        End If
    Next i
    
    'Returns cleaned array to the worksheet
    rw.Cells = MyArray
Next rw

'Deletes all blank cells in the used range
MyRange.SpecialCells(xlCellTypeBlanks).Delete (xlShiftToLeft)

End Sub

 

[HowdeeDoodee]

svr, I ran the new macro posted above. Every word and phrase in the sheet was deleted. This is not what we want. Could you or someone take a look at the macro and revise so only the duplicates in each row are removed leaving one unique in each row.

Just to clarify, if a term is repeated in more than one row, the repeated term should be left in more than one row. I only want to delete repeated terms in the rows in which the terms appear. If the word "cat" appears five times in row 2 and three times in row 3, after the macro is run, the word "cat" should appear once in row 2 and once in row 3.

In some cells, spaces do appear because in some cells, the cells contain a short phrase rather than just one word. If two or more cells contain a phrase, after running the macro in each row, only one cell should contain the phrase in each row.

 

[HowdeeDoodee]

Solved.

Macro was tested and found to be accurate and without errors.

Sub StripRowDupes()
Do Until ActiveCell = ""
Range(ActiveCell, ActiveCell.End(xlToRight)).Select
For Each Cell In Selection
If WorksheetFunction.CountIf(Selection, Cell) > 1 Then
Cell.ClearContents
Else
End If
Next Cell
On Error Resume Next
Selection.SpecialCells(xlCellTypeBlanks).Delete Shift:=xlToLeft
ActiveCell.Range("A2").Select
Loop
End Sub

 

[sweater_vests_rock]

hddd.

thanks for the post -- apologies for my efforts. the issue centered on the use of the filter function. i presumed this returned only exact matches, but with more testing i discovered that it will return substring matches as well (c returns c, ac, a c, etc).

clever solution, but how are you avoiding deleting all occurrences of a duplicate?

thanks. ben.

 

[santi91]

Re: SOLVED - Want to delete duplicate cells in row, row by row

Solved.

Macro was tested and found to be accurate and without errors.

Sub StripRowDupes()
Do Until ActiveCell = ""
Range(ActiveCell, ActiveCell.End(xlToRight)).Select
For Each Cell In Selection
If WorksheetFunction.CountIf(Selection, Cell) > 1 Then
Cell.ClearContents
Else
End If
Next Cell
On Error Resume Next
Selection.SpecialCells(xlCellTypeBlanks).Delete Shift:=xlToLeft
ActiveCell.Range("A2").Select
Loop
End Sub

Hi, i have the same problem.
But with this code, if a row doesn't have any record, the macro is stopped and i have to re-start macro manually.
Could you write me the same macro without this problem? thank you very much