Remove duplicates from range not removing anything-CodePudding

The following code does not remove any duplicate, what am I missing ?

LastColumn = 10

ws.Range(ws.Cells(1, ws.Range("AY1").Column   LastColumn - 1).Address(), ws.Cells(1, "AY").Address()).RemoveDuplicates

I replaced RemoveDuplicates by .Select to check if the excepted range was selected and it was.

CodePudding user response：

Please, test the next way. It will keep only the first occurrences and replace with empty cells the next duplicates. The processed result is returned on the next (second) row (for testing reason). If it works as you need, you can simple replace ws.Range("AY2").Resize with ws.Range("AY1").Resize:

Sub removeDuplicatesOnRow() 
   Dim ws As Worksheet, lastColumn As Long, arrCol, i As Long
   lastColumn = 10
   
   Set ws = ActiveSheet
   arrCol = ws.Range(ws.cells(1, ws.Range("AY1").Column   lastColumn - 1), ws.cells(1, "AY")).value
   arrCol = removeDuplKeepEmpty(arrCol)
   ws.Range("AY2").Resize(1, UBound(arrCol, 2)).value = arrCol
End Sub
Function removeDuplKeepEmpty(arr) As Variant
  Dim ar, dict As Object, i As Long
  ReDim ar(1 To 1, 1 To UBound(arr, 2))
  Set dict = CreateObject("Scripting.Dictionary")
   For i = 1 To UBound(arr, 2)
        If Not dict.Exists(arr(1, i)) Then
            dict(arr(1, i)) = 1
            ar(1, i) = arr(1, i)
        Else
            ar(1, i) = ""
        End If
   Next i
   removeDuplKeepEmpty = ar
End Function

If you need to keep only unique values/strings in consecutive columns, the function can be adapted to do it. You did not answer my clarification question on the issue and I assumed that you do not want ruining the columns below the processed row. But, if my supposition is wrong, I can post a code doing the other way...

CodePudding user response：

Remove Row Duplicates

Option Explicit

Sub RemoveRowDuplicates()
    
    Dim ws As Worksheet: Set ws = ActiveSheet ' be more specific
    Dim fCell As Range: Set fCell = ws.Range("AY1")
    Dim lCell As Range: Set lCell = ws.Cells(1, ws.Columns.Count).End(xlToLeft)
    If lCell.Column < fCell.Column Then Exit Sub ' no data in row range
    
    Dim rg As Range: Set rg = ws.Range(fCell, lCell)
    Dim cCount As Long: cCount = rg.Columns.Count
    If cCount < 2 Then Exit Sub ' only one column
    
    Dim sData As Variant: sData = rg.Value ' Source
    
    Dim dict As Object: Set dict = CreateObject("Scripting.Dictionary")
    dict.CompareMode = vbTextCompare ' ignore case i.e. 'A = a'
    
    Dim dData As Variant: ReDim dData(1 To 1, 1 To cCount) ' Dest. (Result)
    
    Dim sValue As Variant
    Dim sc As Long
    Dim dc As Long
    
    For sc = 1 To cCount
        sValue = sData(1, sc)
        If Not IsError(sValue) Then ' is not an error value
            If Len(sValue) > 0 Then ' is not blank
                If Not dict.Exists(sValue) Then ' not found in dictionary
                    dict(sValue) = Empty
                    dc = dc   1
                    dData(1, dc) = sValue
                'Else ' found in dictionary
                End If
            'Else ' is blank
            End If
        'Else ' is error value
        End If
    Next sc
    
    rg.Value = dData
    
    MsgBox "Found " & dc & " unique values.", vbInformation
    
End Sub