CODEWITHSUNDEEP
vbaexcel
Krystel
Krystel

Reputation: 21

How to copy filtered cells to a new worksheet using VBA

I have this code that automatically filters the data that I need and exports it to a new workbook. However, I need it to be exported into a new sheet in the same workbook. Is there any way to go about this? I am currently using this code:

Sub TestFilter()
Range("D1").AutoFilter Field:=4, Criteria1:="In Scope"
Range("M1").AutoFilter Field:=13, Criteria1:="NOT ASSIGNED"
Range("AG1").AutoFilter Field:=33, Criteria1:="Opening"
ActiveSheet.AutoFilter.Range.Copy
Workbooks.Add.Worksheets(1).Paste
Cells.AutoFilter
End Sub

Thank you!

Upvotes: 2

Views: 8878

Answers (3)

EEM
EEM

Reputation: 6659

I propose the code below based on the following assumptions (in line with the code provided):

  1. The Worksheet with the Source Data is active
  2. The Data Source is already filtered, otherwise the filters applied in the code provided will not work in all situations.

If this is not the case we need to identify and filter the Source Data, the following also applies:

  1. The Data Source starts in cell A1 (as per first filter: Range("D1").AutoFilter Field:=4)
  2. The Data Source at least goes to column 33 (as per third filter: Range("AG1").AutoFilter Field:=33)

Code

Option Explicit

Sub Wsh_CopyFilteredSourceDataToNewWorksheet()
Rem Define variables to work with the Worksheets and Range
Const kColLast = 33
Dim WshSrc As Worksheet
Dim WshTrg As Worksheet
Dim RngSrc As Range

    Set WshSrc = ActiveSheet
    Set WshTrg = WshSrc.Parent.Sheets.Add(After:=WshSrc)

    Rem (1) Set AutoFilter for SourceData starting at "A1"
    With WshSrc
        Rem Reset AutoFilter for Source Worksheet
        If Not (.AutoFilter Is Nothing) Then .Cells(1).AutoFilter
        If .UsedRange.SpecialCells(xlLastCell).Column < kColLast Then
            .Cells(1, kColLast).Value = "Fld." & kColLast
            .Range(.Cells(1), .Cells(.UsedRange.SpecialCells(xlLastCell).Row, kColLast)).AutoFilter
        Else
            .Range(.Cells(1), .UsedRange.SpecialCells(xlLastCell)).AutoFilter
        End If

        Rem Set Filters
        With .AutoFilter.Range
            .AutoFilter Field:=4, Criteria1:="In Scope"
            .AutoFilter Field:=13, Criteria1:="NOT ASSIGNED"
            .AutoFilter Field:=33, Criteria1:="Opening"
    End With: End With

    Rem Copy Filtered Source Data to New Worksheet
    Set RngSrc = WshSrc.AutoFilter.Range.SpecialCells(xlCellTypeVisible)
    With WshTrg.Cells(1)
        RngSrc.Copy
        Rem As per code provided
        .PasteSpecial
        Rem Since we are copying only partial worksheet data I suggest to use the following
        .PasteSpecial xlPasteFormulasAndNumberFormats
        Rem Always Reset CutCopyMode
        Application.CutCopyMode = False
    End With
    WshTrg.UsedRange.Columns.AutoFit

End Sub

Upvotes: 0

brettdj
brettdj

Reputation: 55682

Something like this (where you should edit your range you are filtering)

Sub TestFilter()

Dim ws As Worksheet
Dim ws2 As Worksheet

Set ws = ActiveSheet
ws.AutoFilterMode = False

With ws.Range("A1:AZ100")
    .AutoFilter 4, "In Scope"
    .AutoFilter 13, "NOT ASSIGNED"
    .AutoFilter 33, "Opening"
End With
ws.AutoFilter.Range.Copy
Set ws2 = Sheets.Add(, , Sheets.Count)
ws2.Paste

ws.AutoFilterMode = False
Application.CutCopyMode = False

End Sub

Upvotes: 1

zedfoxus
zedfoxus

Reputation: 37059

You can try something like this (Excel 2013):

Sub Macro1()

    ' set up auto-filter for testing
    Selection.AutoFilter
    ActiveSheet.Range("$A$1:$AG$3000").AutoFilter Field:=1, Criteria1:="John"   ' firstname
    ActiveSheet.Range("$A$1:$AG$3000").AutoFilter Field:=2, Criteria2:="Smith"  ' lastname

    ' copy filtered data by doing CTRL + right-arrow and then CTRL + down arrow
    Range("A1").Select
    Range(Selection, Selection.End(xlToRight)).Select
    Range(Selection, Selection.End(xlDown)).Select
    Selection.Copy

    ' add a sheet after the existing one and paste values
    Sheets.Add After:=ActiveSheet
    Selection.PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks _
        :=False, Transpose:=False

End Sub

Upvotes: 0

Related Questions