# Posted By

angelia on 11/15/12

# Statistics

Viewed 280 times
Favorited by 0 user(s)

# Copy rows based on criteria to a new sheet or file

/ Published in: Visual Basic

Copy rows based on criteria to a new sheet or file

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