Excel 2016 Macro to Copy Range Excluding Duplicates

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