What Will You See If You Copy A Filtered List To Another Worksheet

Suppose you are asked to apply filter on a cavalcade and paste result of a filter into a new worksheet or workbook and same process goes until all the unique values of the column are covered. In other words, this needs to be done for each unique values in a cavalcade in which we take practical filter. It is a very time consuming process if you do it manually. For example, you have a column in which there are 50 unique values. Yous have to exercise it 50 times which is a tedious and error-decumbent job. It can be easily done with Excel VBA programming.

The sample data is shown below :

Filtering and Copying Data

How to Utilise

Open an Excel Workbook
Press Alt+F11 to open VBA Editor
Go to Insert Menu >> Module
In the module, paste the below program
Relieve the file as Macro Enabled Workbook (xlsm) or Excel 97-2003 Workbook (xls)

In the following excel macro, information technology is assumed a filter is practical on column F (Rank) and data starts from cell A1.

Excel Macro : Filter and Paste Unique Values to New Sheets

This macro would filter a column and paste singled-out values to the sheets with their respective names. In this example, it creates four worksheets - ane , 2, 3, 4 as these are unique values in column Rank (column F).

Sub filter() Awarding.ScreenUpdating = False Dim x As Range Dim rng As Range Dim last As Long Dim sht As Cord  'specify sail proper name in which the data is stored sht = "DATA Sheet"  'change filter column in the following code last = Sheets(sht).Cells(Rows.Count, "F").End(xlUp).Row Set up rng = Sheets(sht).Range("A1:F" & final)  Sheets(sht).Range("F1:F" & concluding).AdvancedFilter Activity:=xlFilterCopy, CopyToRange:=Range("AA1"), Unique:=Truthful  For Each x In Range([AA2], Cells(Rows.Count, "AA").End(xlUp))  With rng .AutoFilter .AutoFilter Field:=6, Criteria1:=x.Value .SpecialCells(xlCellTypeVisible).Re-create  Sheets.Add(After:=Sheets(Sheets.Count)).Name = 10.Value ActiveSheet.Paste End With Next 10  ' Turn off filter Sheets(sht).AutoFilterMode = Faux  With Application .CutCopyMode = Imitation .ScreenUpdating = True End With  End Sub

How to Filter and Paste Values to New Workbook

How to Customize the higher up plan

1. Specify name of the sheet in which data is stored. Change the below line of code in the program.

sht = "Data Canvass"

ii. Modify filter column (cavalcade F) and starting cell of range (A1) in the code.

last = Sheets(sht).Cells(Rows.Count, "F").Finish(xlUp).Row
Ready rng = Sheets(sht).Range("A1:F" & terminal)

3. Starting cell of filter cavalcade -F1. Unique values of column F are stored in column AA.

Sheets(sht).Range("F1:F" & last).AdvancedFilter Action:=xlFilterCopy, CopyToRange:=Range("AA1"), Unique:=Truthful
For Each x In Range([AA2], Cells(Rows.Count, "AA").End(xlUp))

four. Modify the value in this part of the code. In this case, 6 refers to column index number (i.e. Column F is sixth column).

.AutoFilter Field:=vi, Criteria1:=x.Value

v. If you run the macro more than than one time, the error would occur every bit sheets already exist. To workaround this outcome, follow the steps below -

(i) Add the following function before sub filter().

Function GetWorksheet(shtName As String) As Worksheet
On Error Resume Next
Set GetWorksheet = Worksheets(shtName)
Finish Office

(two) Add together the following lines of lawmaking afterward 'For Each ten In Range([AA2], Cells(Rows.Count, "AA").End(xlUp))'. Circumspection : Information technology removes the existing worksheets which were created via macro.

If Not GetWorksheet(ten.Text) Is Null So
Sheets(10.Text).Delete
Stop If

6. Suppose you want to copy specific columns instead of all the columns in your sheet. In the plan below, information technology copies columns A, D and F

To change columns which need to be copied, make changes in this line of code -
Set rng1 = Spousal relationship(.Range("A1:A" & last), .Range("D1:D" & final), .Range("F1:F" & final))

Selection Explicit  Function GetWorksheet(shtName As String) As Worksheet     On Error Resume Adjacent     Set GetWorksheet = Worksheets(shtName) Stop Function  Sub filter() Awarding.ScreenUpdating = False Dim ten Equally Range Dim rng Equally Range Dim rng1 As Range Dim last Every bit Long Dim sht As String  'Specify sheet proper name in which the data is stored sht = "DATA Canvas"  'modify filter cavalcade in the following code last = Sheets(sht).Cells(Rows.Count, "F").End(xlUp).Row  With Sheets(sht) Set rng = .Range("A1:F" & last)  'Specific columns which will be copied Set rng1 = Union(.Range("A1:A" & final), .Range("D1:D" & last), .Range("F1:F" & last))  End With  Sheets(sht).Range("F1:F" & last).AdvancedFilter Action:=xlFilterCopy, CopyToRange:=Range("AA1"), Unique:=True  For Each 10 In Range([AA2], Cells(Rows.Count, "AA").Stop(xlUp))  If Not GetWorksheet(x.Text) Is Nothing And then Sheets(x.Text).Delete End If  With rng .AutoFilter .AutoFilter Field:=6, Criteria1:=x.Value Finish With  With rng1 .SpecialCells(xlCellTypeVisible).Copy  Sheets.Add(After:=Sheets(Sheets.Count)).Name = x.Value ActiveSheet.Paste End With Next x  ' Turn off filter Sheets(sht).AutoFilterMode = False  With Application .CutCopyMode = False .ScreenUpdating = True End With  Cease Sub

7. Suppose you want to filter and paste data to a new workbook instead of calculation sheets in the same workbook.

Pick Explicit  Sub filter() Application.ScreenUpdating = Imitation Dim 10 As Range Dim rng As Range Dim rng1 Equally Range Dim final As Long Dim sht As String Dim newBook Every bit Excel.Workbook Dim Workbk Every bit Excel.Workbook  'Specify sheet name in which the data is stored sht = "Information Sail"  'Workbook where VBA code resides Set Workbk = ThisWorkbook  'New Workbook Set newBook = Workbooks.Add together(xlWBATWorksheet) Workbk.Activate  'change filter column in the following code terminal = Workbk.Sheets(sht).Cells(Rows.Count, "F").Terminate(xlUp).Row  With Workbk.Sheets(sht) Fix rng = .Range("A1:F" & last) Stop With  Workbk.Sheets(sht).Range("F1:F" & last).AdvancedFilter Action:=xlFilterCopy, CopyToRange:=Range("AA1"), Unique:=True For Each ten In Workbk.Sheets(sht).Range([AA2], Cells(Rows.Count, "AA").Terminate(xlUp))  With rng .AutoFilter .AutoFilter Field:=6, Criteria1:=x.Value .SpecialCells(xlCellTypeVisible).Re-create  newBook.Sheets.Add(Afterward:=Sheets(Sheets.Count)).Name = 10.Value newBook.Activate ActiveSheet.Paste End With Next ten  ' Turn off filter Workbk.Sheets(sht).AutoFilterMode = False  With Awarding .CutCopyMode = Fake .ScreenUpdating = True End With  Terminate Sub

8. Incase you want to paste information to multiple workbooks subsequently filtering information. Data for each unique value volition be saved in a different workbook with the name same as unique value

Option Explicit  Sub filter() Application.ScreenUpdating = Simulated Dim 10 Equally Range Dim rng Every bit Range Dim rng1 Equally Range Dim last As Long Dim sht As String Dim newBook Every bit Excel.Workbook Dim Workbk As Excel.Workbook  'Specify sheet name in which the data is stored sht = "Information Sheet"  'Workbook where VBA code resides Set Workbk = ThisWorkbook  'change filter column in the following code final = Workbk.Sheets(sht).Cells(Rows.Count, "F").End(xlUp).Row  With Workbk.Sheets(sht) Set rng = .Range("A1:F" & terminal) End With  Workbk.Sheets(sht).Range("F1:F" & last).AdvancedFilter Activity:=xlFilterCopy, CopyToRange:=Range("AA1"), Unique:=True  ' Loop through unique values in column For Each ten In Workbk.Sheets(sht).Range([AA2], Cells(Rows.Count, "AA").End(xlUp))  With rng .AutoFilter .AutoFilter Field:=half-dozen, Criteria1:=x.Value .SpecialCells(xlCellTypeVisible).Copy  'Add together New Workbook in loop Set newBook = Workbooks.Add(xlWBATWorksheet)  newBook.Sheets.Add together(Later:=Sheets(Sheets.Count)).Name = x.Value newBook.Activate ActiveSheet.Paste End With  'Salvage new workbook newBook.SaveAs x.Value & ".xlsx"  'Close workbook newBook.Shut SaveChanges:=False  Side by side ten  ' Plough off filter Workbk.Sheets(sht).AutoFilterMode = False  With Application .CutCopyMode = False .ScreenUpdating = True Finish With  End Sub

You lot can remove this line of lawmaking if you lot don't want to close the newly created workbooks.
newBook.Close SaveChanges:=Imitation

9. Suppose yous desire to sum values in each worksheet. The following program sums column B of each worksheet. Information technology as well writes 'Full' at last row of column A. It assumes your data starts from cavalcade A.

Sub sumLoop()
Dim WS Every bit Worksheet
For Each WS In ThisWorkbook.Worksheets
WS.Actuate
Range("A" & Rows.Count).End(xlUp).Select
final = Selection.Row
totRow = concluding + 1
WS.Range("A" & totRow) = "Total"
WS.Range("B" & totRow) = Application.WorksheetFunction.Sum(Columns("B:B"))
Next WS
Terminate Sub

10. How to filter merely one value instead of all the unique values
Remove the post-obit line of code -

                      Sheets(sht).Range("F1:F" & terminal).AdvancedFilter Activeness:=xlFilterCopy, CopyToRange:=Range("AA1"), Unique:=True

Next step is to enter the value you want to filter in prison cell AA2 and make sure nothing is filled in the whole column AA except prison cell AA2. For example I would enter value 1 in cell AA2 as I want to select 1 in column F ('rank' column).

Click on the link beneath to bank check out the working macro

Related Link - Filter Information Based on Driblet Downward Selection