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 macro copies the filtered data to Sheet2... 

'Force the explicit declaration of variables
Option Explicit

Sub CopyFilteredData()

    'Declare the variables
    Dim wksDest As Worksheet
    Dim Rng As Range
    Dim CellCount As Long
    Dim Msg As String
    
    'Set the destination worksheet
    Set wksDest = Worksheets("Sheet2")
    
    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 & "Sort the data, and try again!"
                MsgBox Msg, vbExclamation, "SpecialCells Limitation"
                GoTo ExitTheSub
            End If
            
        End If
        
        'Set the range for the filtered data, excluding the header row
        On Error Resume Next
        Set Rng = .Resize(.Rows.Count - 1).Offset(1, 0) _
            .SpecialCells(xlCellTypeVisible)
        On Error GoTo 0
        
        'If filtered data exists, copy it to the destination worksheet
        'below the existing data
        If Not Rng Is Nothing Then
            Rng.Copy Destination:=wksDest.Cells(GetLastRow(wksDest), "a")(2)
        Else
            MsgBox "No records are available to copy...", vbExclamation
        End If
        
    End With
    
ExitTheSub:

    'If the active sheet is in filter mode, make all the data visible
    With ActiveSheet
        If .FilterMode Then .ShowAllData
    End With
    
End Sub

Private Function GetLastRow(wks As Worksheet)
    GetLastRow = wks.Cells.Find( _
                What:="*", _
                After:=wks.Range("A1"), _
                LookIn:=xlFormulas, _
                Lookat:=xlPart, _
                SearchOrder:=xlByRows, _
                SearchDirection:=xlPrevious, _
                MatchCase:=False).Row
End Function

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".

Last Update: May 11, 2012

Home | Excel | VBA | About | Contact