复制并粘贴过滤列中的唯一值

Question

我正在尝试从筛选范围中获取唯一值并尝试将其粘贴到特定工作表中。但是我遇到了运行-时间错误 1004（数据库或 Table 范围无效）。

Set DataSet = MainSht.Range(Cells(1, 1), Cells(Lrows, Lcols))

With DataSet
    .AutoFilter field:=3, Criteria1:=Array("Corporate Treasury - US", "F&A"), Operator:=xlFilterValues
    Set DataRng = .Offset(1, 10).Resize(.Rows.Count - 1, 1).SpecialCells(xlCellTypeVisible)
    .AutoFilter
    With DataRng
    .AdvancedFilter Action:=xlFilterCopy, copytorange:=Wb.Sheets("Corporate Treasury - US").Range("A2"), Unique:=True 'Getting Error Here
    End With
End With

提前感谢您的帮助！！

Answer 1

我认为错误是因为它不能超过列中的一系列非连续单元格。

我通过简单地使用 .copy 命令解决了这个问题，但这将使用基础格式粘贴您的唯一列表。请参阅下面的解决方案 -

> Set DataSet = MainSht.Range(Cells(1, 1), Cells(Lrows, Lcols))
> 
> With DataSet
>     .AutoFilter field:=3, Criteria1:=Array("Corporate Treasury - US", "F&A"), Operator:=xlFilterValues
>     Set DataRng = .Offset(1, 10).Resize(.Rows.Count - 1, 1).SpecialCells(xlCellTypeVisible)
>     DataRng.Copy Destination:=Wb.Sheets("Corporate Treasury - US").Range("A2:A" & (DataRng.Rows.Count + 2))
> 
> End With

如果您不想从原始工作表中跨过单元格 properties/formatting，您可以将 .copy 命令与 .pastespecial 结合使用，以便仅粘贴值、公式或其他内容您需要的详细信息。

Answer 2

复制过滤后的唯一数据

基本上

'Remove' 个以前的过滤器。
在应用 AutoFilter.

创建准确的范围引用

过滤器应用于Table范围（包括headers）。
使用 SpecialCells 的错误处理（假设 未找到单元格 ）。
将SpecialCells应用于数据范围（无headers）。
在创建对 SpecialCells 范围的引用后，'remove' 过滤器通常是安全的。
Copy/paste 然后才应用 RemoveDuplicates（xlNo 当 数据范围 ）。
可选地，将 Sort（xlNo 当 数据范围 ）应用于不一定准确的目标范围（ducdrg 即没有空单元格（由于 RemoveDuplicates））。
(xlYes 当 Table 范围 。)

一项研究

调整常量部分中的值（工作表已关闭）。

Option Explicit

Sub CopyFilteredUniqueData()

    ' Source
    
    Const sName As String = "Sheet1"
    ' Copy
    Const sCol As Variant = "K" ' or 11
    ' Filter
    Const sfField As Long = 3
    Dim sfCriteria1 As Variant
    sfCriteria1 = Array("Corporate Treasury - US", "F&A")
    Dim sfOperator As XlAutoFilterOperator: sfOperator = xlFilterValues
    
    ' Destination
    
    Const dName As String = "Sheet2"
    ' Paste
    Const dFirst As String = "A2"

    ' Workbook
    Dim wb As Workbook: Set wb = ThisWorkbook ' workbook containing this code
    
    ' Source
        
    Dim sws As Worksheet: Set sws = wb.Worksheets(sName)
    Debug.Print vbLf & "Source (""" & sws.Name & """)"
    
    ' Remove possble previous filters.
    If sws.AutoFilterMode Then
        sws.AutoFilterMode = False
    End If
    
    ' Source Table Range
    Dim strg As Range: Set strg = sws.Range("A1").CurrentRegion
    Debug.Print strg.Address(0, 0)
    
    ' Source Column Data Range (No Headers)
    Dim scdrg As Range
    With strg.Columns(sCol)
        Set scdrg = .Resize(.Rows.Count - 1).Offset(1)
    End With
    Debug.Print scdrg.Address(0, 0) & " (No Headers)"
 
    ' Filter.
    strg.AutoFilter sfField, sfCriteria1, sfOperator
    
    ' Source Filtered Column Data Range (No Headers)
    On Error Resume Next
    Dim sfcdrg As Range: Set sfcdrg = scdrg.SpecialCells(xlCellTypeVisible)
    On Error GoTo 0
    sws.AutoFilterMode = False ' no need for the filter anymore
    If sfcdrg Is Nothing Then Exit Sub ' no matching cells
    Debug.Print sfcdrg.Address(0, 0) & " (No Headers)"
    
    ' Destination
    
    Dim dws As Worksheet: Set dws = wb.Worksheets(dName)
    Debug.Print vbLf & "Destination (""" & dws.Name & """)"
    
    ' Destination First Cell
    Dim dfCell As Range: Set dfCell = dws.Range(dFirst)
    
    ' Destination Column Data Range (No Headers)
    Dim dcdrg As Range: Set dcdrg = dfCell.Resize(sfcdrg.Cells.Count)
    Debug.Print dcdrg.Address(0, 0) & " (No Headers)"
     
    ' Copy.
    sfcdrg.Copy dcdrg
    
    ' Remove duplicates.
    dcdrg.RemoveDuplicates 1, xlNo
    Debug.Print dcdrg.Address(0, 0) & " (No Headers, Empty Cells Included)"
    
    ' Destination Last Cell
    Dim dlCell As Range
    Set dlCell = dcdrg.Find("*", , xlFormulas, , , xlPrevious)
    
    ' Destination Unique Column Data Range (No Headers)
    Dim ducdrg As Range
    With dcdrg
        Set ducdrg = .Resize(dlCell.Row - .Row + 1)
    End With
    Debug.Print ducdrg.Address(0, 0) & " (No Headers, Empty Cells Excluded)"
    
    ' Sort ascending.
    ducdrg.Sort ducdrg, , Header:=xlNo
    
End Sub

复制并粘贴过滤列中的唯一值

Copy and Paste the Unique Values from Filtered Column

excel

vba

autofilter

advanced-filter

复制过滤后的唯一数据