CODEWITHSUNDEEP
excelvbaautofilteradvanced-filter
mrk777
mrk777

Reputation: 167

Copy and Paste the Unique Values from Filtered Column

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!!

Upvotes: 1

Views: 633

Answers (2)

VBasic2008
VBasic2008

Reputation: 54807

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

Upvotes: 1

SpikeManZombie
SpikeManZombie

Reputation: 31

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.

Upvotes: 0

Related Questions