Copy, Remove Duplicates, Paste V

Question

I am trying to copy a list, remove duplicates, and paste it elsewhere but for some reason it is keeping two out of the three copies of 1--see attached. Not sure why its doing that, any help would be greatly appreciated.

Answer 1

Advanced filter assumes the top cell is a header and doesn't count it as one of the duplicates.

To fix this, you'll want to add in another row at the top as a header and then run your code. You can delete this header cell afterwards if you prefer.

If adding a header is not an option, you could use remove duplicates as a separate step. Unlike advanced filter, you can tell remove duplicates that you don't have a header. Just change your code to this:

Sub VBARemoveDuplicate()

    Range("A1", Range("A1").End(xlDown)).Select
    Selection.Copy Range("B1")
    Range("B1", Range("B1").End(xlDown)).RemoveDuplicates Columns:=1, Header:=xlNo

End Sub
    

Edit:

Another alternative would be to delete the missed duplicate on the backend as I did below.

Sub VBARemoveDuplicate()
    Range("A1", Range("A1").End(xlDown)).Select
    Selection.AdvancedFilter Action:=xlFilterCopy, CopyToRange:=Range("B1"), Unique:=True
    
    For Each cell In Range("A2", Range("A2").End(xlDown))
        If cell.Value = Range("A1").Value Then
            Range("B1").Delete xlShiftUp
        End If
    Next cell
End Sub

Beyond this, you would need to load everything into an array and, loop through and remove duplicates, and then place them back into the sheet. This could be slow if you have a large dataset.

Answer 2

Copy Unique Values to Another Column (Dictionary)

• Adjust (play with) the values in the constants section.

Option Explicit

Sub VBARemoveDuplicates()
    Const ProcName As String = "VBARemoveDuplicates"
    On Error GoTo ClearError
    
    Const sFirst As String = "A1"
    Const dFirst As String = "B1"
    Const doClearContentsBelow As Boolean = True
    Const doAutoFitColumn As Boolean = True
    
    ' Create a reference to the worksheet.
    Dim ws As Worksheet: Set ws = ActiveSheet
    
    ' Create a reference to the Source Column Range ('srg').
    Dim sfCell As Range: Set sfCell = ws.Range(sFirst)
    Dim srg As Range: Set srg = RefColumn(sfCell)
    If srg Is Nothing Then Exit Sub
    
    ' Write the unique values from the Source Column Range
    ' to the Data Array ('Data').
    Dim Data As Variant: Data = GetUniqueColumnRange(srg)
    If IsEmpty(Data) Then Exit Sub
    
    ' Write the values from the Data Array
    ' to the Destination Column Range ('drg').
    Dim dfCell As Range: Set dfCell = ws.Range(dFirst)
    Dim rCount As Long: rCount = UBound(Data, 1)
    Dim drg As Range: Set drg = dfCell.Resize(rCount)
    drg.Value = Data
    
    ' Clear the contents in the cells of the Clear Range ('crg'),
    ' the range from the first cell below the Destination Column Range
    ' through the last cell in the column.
    If doClearContentsBelow Then
        Dim crg As Range
        Set crg = dfCell.Resize(ws.Rows.Count - dfCell.Row - rCount + 1) _
            .Offset(rCount)
        crg.ClearContents
    End If
    
    ' Autofit the Destination Column.
    If doAutoFitColumn Then
        dfCell.EntireColumn.AutoFit
    End If
    
ProcExit:
    Exit Sub
ClearError:
    Debug.Print "'" & ProcName & "': Unexpected Error!" & vbLf _
              & "    " & "Run-time error '" & Err.Number & "':" & vbLf _
              & "        " & Err.Description
    Resume ProcExit
End Sub

''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''
' Purpose:      Creates a reference to the range from the first cell
'               in a column ('ColumnIndex') of a range ('rg') through
'               the last non-empty cell in the column.
''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''
Function RefColumn( _
    ByVal rg As Range, _
    Optional ByVal ColumnIndex As Long = 1) _
As Range
    Const ProcName As String = "RefColumn"
    On Error GoTo ClearError
    
    ' Validate the parameters.
    If rg Is Nothing Then Exit Function
    ' Also, prevent referencing columns outside of the range.
    If ColumnIndex < 1 Then Exit Function
    If ColumnIndex > rg.Columns.Count Then Exit Function
    
    ' Create a reference to the range.
    With rg.Rows(1).Columns(ColumnIndex)
        Dim lCell As Range
        Set lCell = .Resize(.Worksheet.Rows.Count - .Row + 1) _
            .Find("*", , xlFormulas, , , xlPrevious)
        If lCell Is Nothing Then Exit Function
        Set RefColumn = .Resize(lCell.Row - .Row + 1)
    End With

ProcExit:
    Exit Function
ClearError:
    Debug.Print "'" & ProcName & "': Unexpected Error!" & vbLf _
              & "    " & "Run-time error '" & Err.Number & "':" & vbLf _
              & "        " & Err.Description
    Resume ProcExit
End Function

''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''
' Purpose:      Returns the unique values from a column ('ColumnIndex')
'               of a range ('rg') in a 2D one-based one-column array.
' Remarks:      Error and blank values are excluded.
''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''
Function GetUniqueColumnRange( _
    ByVal rg As Range, _
    Optional ByVal ColumnIndex As Long = 1) _
As Variant
    Const ProcName As String = "GetUniqueColumnRange"
    On Error GoTo ClearError

    ' Validate the parameters.
    If rg Is Nothing Then Exit Function
    ' Also, prevent referencing columns outside of the range.
    If ColumnIndex < 1 Then Exit Function
    If ColumnIndex > rg.Columns.Count Then Exit Function
    
    ' Return the values of the column of the range
    ' in a 2D one-based one-column array.
    Dim Data As Variant
    Dim rCount As Long
    With rg.Columns(ColumnIndex)
        rCount = .Rows.Count
        If rCount = 1 Then
            ReDim Data(1 To 1, 1 To 1): Data(1, 1) = .Value
        Else
            Data = .Value
        End If
    End With
    
    ' Return the unique values of the array
    ' in the keys of a dictionary.
    Dim dict As Object: Set dict = CreateObject("Scripting.Dictionary")
    dict.CompareMode = vbTextCompare
    Dim Key As Variant
    Dim r As Long
    For r = 1 To rCount
        Key = Data(r, 1)
        If Not IsError(Key) Then
            If Len(Key) > 0 Then
                dict(Key) = Empty
            End If
        End If
    Next r
    
    ' If all values of the column of the range are not unique,
    ' return the keys of the dictionary
    ' in another 2D one-based one-column array.
    r = dict.Count
    Select Case r
    Case 0 ' only error and blank values
        Exit Function
    Case Is < rCount ' fewer unique values than values
        ReDim Data(1 To r, 1 To 1)
        r = 0
        For Each Key In dict.Keys
            r = r + 1
            Data(r, 1) = Key
        Next Key
    'Case rCount ' all values are unique - no duplicates
    End Select
    
    ' Return the array.
    GetUniqueColumnRange = Data

ProcExit:
    Exit Function
ClearError:
    Debug.Print "'" & ProcName & "': Unexpected Error!" & vbLf _
              & "    " & "Run-time error '" & Err.Number & "':" & vbLf _
              & "        " & Err.Description
    Resume ProcExit
End Function