Excel 2016 Macro to Copy Range Excluding Duplicates - excel

Question

I have put together the following code to copy a range of IDs. The range contains many duplicates and I just want to paste one occurrence of each ID.
I keep getting a syntax error and I can't see what I am doing wrong. Can anyone point out the issue?
Thanks
Sub CopyIDs()
With ThisWorkbook.Sheets("DataTable").Range("A1", .Range("A1").End(xlDown)).AdvancedFilter Action:=xlFilterCopy, CopyToRange:=ThisWorkbook.Sheets("Analysis").Range("A8"), Unique:=True
ThisWorkbook.Sheets("Analysis").Range("A8").Delete Shift:=xlShiftUp
End With
End Sub

Answer 1

You use "With" and "End With" in an incorrect way.
If you want to skip to specify the "Date Table" sheets twice, you may refer below code
With ThisWorkbook.Sheets("DataTable")
.Range("A1", .Range("A1").End(xlDown)).AdvancedFilter Action:=xlFilterCopy, CopyToRange:=ThisWorkbook.Sheets("Analysis").Range("A8"), Unique:=True
End With

Answer 2

Advanced Filter vs Dictionary
The following contains 2 Advanced Filter solutions and 2 Dictionary solutions the latter using the getUniqueColumn function.
The Code
Option Explicit
' Stand-Alone
Sub copyIDsQF()
' To prevent 'Run-time error '1004':
' The extract range has a missing or invalid field name.':
ThisWorkbook.Worksheets("Analysis").Range("A8").ClearContents
With ThisWorkbook.Worksheets("DataTable")
.Range("A1", .Range("A1").End(xlDown)).AdvancedFilter _
Action:=xlFilterCopy, _
CopyToRange:=ThisWorkbook.Worksheets("Analysis").Range("A8"), _
Unique:=True
End With
ThisWorkbook.Worksheets("Analysis").Range("A8").Delete Shift:=xlShiftUp
End Sub
' Stand-Alone
Sub CopyIDsCool()
With ThisWorkbook
' Define Source Column Range.
Dim SourceRange As Range
With .Worksheets("DataTable")
' If you ars sure that the range is contiguous:
Set SourceRange = .Range("A1", .Range("A1").End(xlDown))
' If not, rather use the following:
'Set SourceRange = .Range("A1", .Cells(.Rows.Count, "A").End(xlUp))
' but then you could have the empty string as a unique value.
End With
' Define Target First Cell Range.
Dim TargetFirstCell As Range
Set TargetFirstCell = .Worksheets("Analysis").Range("A8")
End With
Application.ScreenUpdating = False
' To prevent 'Run-time error '1004':
' The extract range has a missing or invalid field name.':
TargetFirstCell.ClearContents
' Copy unique values from Source Column Range to Target Column Range.
SourceRange.AdvancedFilter Action:=xlFilterCopy, _
CopyToRange:=TargetFirstCell, _
Unique:=True
' Delete Target First Cell Range i.e. remove copied header.
TargetFirstCell.Delete Shift:=xlShiftUp
Application.ScreenUpdating = True
End Sub
' Uses the getUniqueColumn Function.
Sub CopyIDsMagicNumbers()
' Write unique values from Source Column to Data Array ('Data').
Dim Data As Variant
Data = getUniqueColumn(ThisWorkbook.Worksheets("DataTable"), "A", 2)
' Validate Data Array.
If IsEmpty(Data) Then
GoTo ProcExit
End If
' Write values from Data Array to Target Range.
With ThisWorkbook.Worksheets("Analysis").Range("A8")
' Clear contents in Target Column from Target First Cell to bottom.
.Resize(.Worksheet.Rows.Count - .Row + 1).ClearContents
' Write values from Data Array to Target Range.
.Resize(UBound(Data, 1)).Value = Data
End With
ProcExit:
End Sub
' Uses the getUniqueColumn Function.
Sub CopyIDs()
' Source
Const srcName As String = "DataTable"
Const UniCol As Variant = "A"
Const FirstRow As Long = 2
' Target
Const tgtName As String = "Analysis"
Const tgtFirstCell As String = "A8"
' Workbook
Dim wb As Workbook
Set wb = ThisWorkbook
' Write unique values from Source Column to Data Array ('Data').
Dim Data As Variant
Data = getUniqueColumn(wb.Worksheets(srcName), UniCol, FirstRow)
' Validate Data Array.
If IsEmpty(Data) Then
GoTo ProcExit
End If
' Write values from Data Array to Target Range.
With wb.Worksheets(tgtName).Range(tgtFirstCell)
' Clear contents in Target Column from Target First Cell to bottom.
.Resize(.Worksheet.Rows.Count - .Row + 1).ClearContents
' Write values from Data Array to Target Range.
.Resize(UBound(Data, 1)).Value = Data
End With
ProcExit:
End Sub
''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''
' Purpose: Returns the unique values of a column range
' in a 2D one-based one-column array.
''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''
Function getUniqueColumn(Sheet As Worksheet, _
Optional ByVal ColumnIndex As Variant = 1, _
Optional ByVal FirstRow As Long = 1) _
As Variant
' Validate worksheet.
If Sheet Is Nothing Then
GoTo ProcExit ' Worksheet is 'Nothing'.
End If
' Define Processing Range ('rng').
Dim rng As Range
Set rng = Sheet.Columns(ColumnIndex) _
.Resize(Sheet.Rows.Count - FirstRow + 1) _
.Offset(FirstRow - 1)
' Define Last Non-Empty Cell ('cel') in Processing Range.
Dim cel As Range
Set cel = rng.Find(What:="*", _
LookIn:=xlFormulas, _
SearchDirection:=xlPrevious)
' Validate Last Non-Empty Cell.
If cel Is Nothing Then
GoTo ProcExit ' Processing Range is empty.
End If
' Define Non-Empty Column Range ('rng').
Set rng = rng.Resize(cel.Row - FirstRow + 1)
' Write values from Non-Empty Column Range to Data Array ('Data').
Dim Data As Variant
If rng.Rows.Count > 1 Then
Data = rng.Value
Else
ReDim Data(1, 1)
Data(1, 1) = rng.Value
End If
' Write values from Data Array to Unique Dictionary ('dict').
Dim dict As Object
Set dict = CreateObject("Scripting.Dictionary")
Dim Key As Variant
Dim i As Long
For i = 1 To UBound(Data)
Key = Data(i, 1)
If Not IsError(Key) And Not IsEmpty(Key) Then
dict(Key) = Empty
End If
Next i
' Validate Unique Dictionary.
If dict.Count = 0 Then
GoTo ProcExit ' There are only error and/or empty values in Data Array.
End If
' Write values from Unique Dictionary to Data Array ('Data').
ReDim Data(1 To dict.Count, 1 To 1)
i = 0
For Each Key In dict.Keys
i = i + 1
Data(i, 1) = Key
Next Key
' Write Data Array to result.
getUniqueColumn = Data
ProcExit:
End Function