Excel 2016 宏复制排除重复项的范围

Question

我已将以下代码放在一起以复制一系列 ID。 该范围包含许多重复项，我只想粘贴每个 ID 的一次出现。

我不断收到语法错误，我看不出我做错了什么。 谁能指出这个问题？

谢谢

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

您以错误的方式使用“With”和“End With”。 如果你想跳过两次指定“日期表”表，你可以参考下面的代码

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

高级过滤器与字典

• 以下包含 2 个高级过滤器解决方案和 2 个字典解决方案，后者使用getUniqueColumn函数。

编码

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