Advanced Search

Copy rows based on criteria to a new sheet or file

/ Published in: Visual Basic
Save to your folder(s)
Copy rows based on criteria to a new sheet or file

Expand | Embed | Plain Text

Copy this code and paste it in your HTML 
  1. Sub Extract_All_Data()
  2.  
  3.     'this macro assumes that your first row of data is a header row.
  4.     'will copy all filtered rows from one worksheet, to another blank workbook
  5.     'each unique filtered value will be copied to it's own sheet
  6.  
  7.     'Variables used by the macro
  8.     Dim wbDest As Workbook
  9.     Dim rngFilter As Range, rngUniques As Range
  10.     Dim cell As Range, counter As Integer
  11.  
  12.     ' Set the filter range (from A1 to the last used cell in column A)
  13.     '(Note: you can change this to meet your requirements)
  14.     Set rngFilter = Range("A1", Range("A" & Rows.count).End(xlUp))
  15.  
  16.     Application.ScreenUpdating = False
  17.  
  18.     With rngFilter
  19.  
  20.         ' Filter column A to show only one of each item (uniques) in column A
  21.         .AdvancedFilter Action:=xlFilterInPlace, Unique:=True
  22.  
  23.         ' Set a variable to the Unique values
  24.         Set rngUniques = Range("A2", Range("A" & Rows.count).End(xlUp)).SpecialCells(xlCellTypeVisible)
  25.  
  26.         ' Clear the filter
  27.         On Error Resume Next
  28.         ActiveSheet.ShowAllData
  29.  
  30.     End With
  31.  
  32.     ' Create a new workbook with a sheet for each unique value
  33.     Application.SheetsInNewWorkbook = rngUniques.count
  34.     Set wbDest = Workbooks.add
  35.     Application.SheetsInNewWorkbook = 3
  36.  
  37.     ' Filter, Copy, and Paste each unique to its' own sheet in the new workbook
  38.     For Each cell In rngUniques
  39.  
  40.         counter = counter + 1
  41.  
  42.         'NOTE - this filter is on column A (field:=1), to change
  43.         'to a different column you need to change the field number
  44.         rngFilter.AutoFilter field:=1, Criteria1:=cell.Value
  45.  
  46.         ' Copy and paste the filtered data to it's unique sheet
  47.         rngFilter.Resize(, 16).SpecialCells(xlCellTypeVisible).Copy Destination:=wbDest.Sheets(counter).Range("A1")
  48.         ' Name the destination sheet
  49.         wbDest.Sheets(counter).Name = cell.Value
  50.         wbDest.Sheets(counter).Cells.Columns.AutoFit
  51.  
  52.     Next cell
  53.  
  54.     rngFilter.Parent.AutoFilterMode = False
  55.     Application.ScreenUpdating = True
  56.  
  57. End Sub

Report this snippet


Comments

RSS Icon Subscribe to comments

You need to login to post a comment.