Copy the Filtered Data after Filtering with the AutoFilter

Assuming that the sheet containing the data is the active sheet, and that the data has been filtered with the AutoFilter, the following procedure copies the filtered data to Sheet2...

'Force the explicit declaration of variables
Option Explicit

Sub CopyFilteredData()

    'Declare the variables
    Dim wksDest As Worksheet
    Dim rngFilt As Range
    Dim CellCount As Long
    Dim Msg As String
    
    'If the data has not been filtered with the AutoFilter, exit the sub
    With ActiveSheet
        If .AutoFilterMode = False Or .FilterMode = False Then
            MsgBox "Please filter the data with the AutoFilter, and try again!"
            Exit Sub
        End If
    End With
    
    'Set the destination worksheet
    Set wksDest = Worksheets("Sheet2")
    
    'Clear the destination worksheet
    wksDest.Cells.Clear
        
    With ActiveSheet.AutoFilter.Range
    
        'For Excel 2007 and earlier, check for the SpecialCells limitation
        If Val(Application.Version) < 14 Then
        
            On Error Resume Next
            CellCount = .Columns(1).SpecialCells(xlCellTypeVisible) _
                .Areas(1).Cells.Count
            On Error GoTo 0
            
            If CellCount = 0 Then
                Msg = "The SpecialCells limit of 8,192 areas has been "
                Msg = Msg & vbNewLine
                Msg = Msg & "exceeded for the filtered value."
                Msg = Msg & vbNewLine & vbNewLine
                Msg = Msg & "Tip:  Sort the data, and try again!"
                MsgBox Msg, vbExclamation, "SpecialCells Limitation"
                GoTo ExitTheSub
            End If
            
        End If
        
        'Set the filtered range
        On Error Resume Next
        Set rngFilt = .Resize(.Rows.Count - 1).Offset(1, 0) _
            .SpecialCells(xlCellTypeVisible)
        On Error GoTo 0
        
        'Copy the filtered data to the destination worksheet
        If Not rngFilt Is Nothing Then
            rngFilt.Copy Destination:=wksDest.Range("A2")
        Else
            MsgBox "No records are available to copy...", vbExclamation
        End If
        
    End With
        
ExitTheSub:

    'Clear the filter
    ActiveSheet.ShowAllData
    
End Sub

Tip: To include the column headers, replace...

rngFilt.Copy Destination:=wksDest.Range("A2")

with

.Copy Destination:=wksDest.Range("A1")

Where to Put the Code

  1. Open the workbook in which to store the code.
  2. Open the Visual Basic Editor (Alt+F11).
  3. Insert a standard module (Insert > Module).
  4. Copy/paste the above code into the module.
  5. Return to Microsoft Excel (Alt+Q).
  6. Save the workbook.

How to Use the Macro

  1. Display the Macro dialog box (Alt+F8).
  2. Click/select the macro called "CopyFilteredData".
  3. Click/select "Run".

Home | Excel | VBA | Blog | About | Contact