I'm trying to get the Unique values from the Filtered Range and trying to paste the same into specific worksheet. But I'm facing a Run-Time Error 1004 (Database or Table Range is not Valid).

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

Appreciate your help in advance!!

CodePudding user response：

I believe the error is because it cannot past a range of non-contiguous cells within a column.

I got round this by simply using the .copy command, but this will paste your unique list with the underlying formatting. See my solution below -

> 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

If you do not want to bring across cell properties/formatting from the original worksheet, you could combine the .copy command with a .pastespecial to only paste in values, formulas or whatever details you need.

CodePudding user response：

Copy Filtered Unique Data

Basically

• 'Remove' previous filters.
• Create accurate range references before applying AutoFilter.
• The filter is applied on the Table Range (headers included).
• Use error handling with SpecialCells (think no cells found).
• Apply SpecialCells to the Data Range (no headers).
• It is usually safe to 'remove' the filter after the reference to the SpecialCells range is created.
• Copy/paste and only then apply RemoveDuplicates (xlNo when Data Range).
• Optionally, apply Sort (xlNo when Data Range) to the not necessarily exact destination range (ducdrg i.e. no empty cells (due to RemoveDuplicates)).
• (xlYes when Table Range.)

A Study

• Adjust the values in the constants section (the worksheets are off).

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