Return to Snippet

Revision: 60878
at November 15, 2012 05:57 by angelia

Initial Code
Sub Extract_All_Data()

    'this macro assumes that your first row of data is a header row.
    'will copy all filtered rows from one worksheet, to another blank workbook
    'each unique filtered value will be copied to it's own sheet
    'Variables used by the macro
    Dim wbDest As Workbook
    Dim rngFilter As Range, rngUniques As Range
    Dim cell As Range, counter As Integer
    ' Set the filter range (from A1 to the last used cell in column A)
    '(Note: you can change this to meet your requirements)
    Set rngFilter = Range("A1", Range("A" & Rows.count).End(xlUp))
    Application.ScreenUpdating = False
    With rngFilter
        ' Filter column A to show only one of each item (uniques) in column A
        .AdvancedFilter Action:=xlFilterInPlace, Unique:=True
        ' Set a variable to the Unique values
        Set rngUniques = Range("A2", Range("A" & Rows.count).End(xlUp)).SpecialCells(xlCellTypeVisible)
        ' Clear the filter
        On Error Resume Next
    End With
    ' Create a new workbook with a sheet for each unique value
    Application.SheetsInNewWorkbook = rngUniques.count
    Set wbDest = Workbooks.add
    Application.SheetsInNewWorkbook = 3

    ' Filter, Copy, and Paste each unique to its' own sheet in the new workbook
    For Each cell In rngUniques
        counter = counter + 1
        'NOTE - this filter is on column A (field:=1), to change
        'to a different column you need to change the field number
        rngFilter.AutoFilter field:=1, Criteria1:=cell.Value
        ' Copy and paste the filtered data to it's unique sheet
        rngFilter.Resize(, 16).SpecialCells(xlCellTypeVisible).Copy Destination:=wbDest.Sheets(counter).Range("A1")
        ' Name the destination sheet
        wbDest.Sheets(counter).Name = cell.Value
    Next cell
    rngFilter.Parent.AutoFilterMode = False
    Application.ScreenUpdating = True
End Sub

Initial URL

Initial Description
Copy rows based on criteria to a new sheet or file

Initial Title
Copy rows based on criteria to a new sheet or file

Initial Tags

Initial Language
Visual Basic