Copy, Remove Duplicates, Paste V - excel

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