Excel VBA : Filtering and copy pasting to new sheet or workbook

Suppose you are asked to apply filter on a column 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 column in which we have applied 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. You have to do it 50 times which is a tedious and error-prone task. It can be easily done with Excel VBA programming.

The sample data is shown below :

Filtering and Copying Data

How to Use

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

In the following excel macro, it is assumed a filter is applied 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 distinct values to the sheets with their respective names. In this case, it creates four worksheets - 1 , 2, 3, 4 as these are unique values in column Rank (column F).

Sub filter()
Application.ScreenUpdating = False
Dim x As Range
Dim rng As Range
Dim last As Long
Dim sht As String

'specify sheet 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 rng = Sheets(sht).Range("A1:F" & last)

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

For Each x In Range([AA2], Cells(Rows.Count, "AA").End(xlUp))
With rng
.AutoFilter
.AutoFilter Field:=6, Criteria1:=x.Value
.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

End Sub

How to Filter and Paste Values to New Workbook

How to Customize the above program

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

sht = "DATA Sheet"

2. Change filter column (column F) and starting cell of range (A1) in the code.

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

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

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

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

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

5. If you run the macro more than once, the error would occur as sheets already exist. To workaround this issue, 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)
End Function

(ii) Add the following lines of code after 'For Each x In Range([AA2], Cells(Rows.Count, "AA").End(xlUp))'. Caution : It removes the existing worksheets which were created via macro.

If Not GetWorksheet(x.Text) Is Nothing Then
Sheets(x.Text).Delete
End If

6. Suppose you want to copy specific columns instead of all the columns in your sheet. In the program below, it copies columns A, D and F
To change columns which need to be copied, make changes in this line of code -
Set rng1 = Union(.Range("A1:A" & last), .Range("D1:D" & last), .Range("F1:F" & last))

Option Explicit

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

Sub filter()
Application.ScreenUpdating = False
Dim x As Range
Dim rng As Range
Dim rng1 As Range
Dim last As Long
Dim sht As String

'Specify sheet 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

With Sheets(sht)
Set rng = .Range("A1:F" & last)

'Specific columns which will be copied
Set rng1 = Union(.Range("A1:A" & last), .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 x In Range([AA2], Cells(Rows.Count, "AA").End(xlUp))

If Not GetWorksheet(x.Text) Is Nothing Then
Sheets(x.Text).Delete
End If

With rng
.AutoFilter
.AutoFilter Field:=6, Criteria1:=x.Value
End 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

End Sub

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

Option Explicit

Sub filter()
Application.ScreenUpdating = False
Dim x As Range
Dim rng As Range
Dim rng1 As Range
Dim last As Long
Dim sht As String
Dim newBook As Excel.Workbook
Dim Workbk As Excel.Workbook

'Specify sheet name in which the data is stored
sht = "DATA Sheet"

'Workbook where VBA code resides
Set Workbk = ThisWorkbook

'New Workbook
Set newBook = Workbooks.Add(xlWBATWorksheet)
Workbk.Activate

'change filter column in the following code
last = Workbk.Sheets(sht).Cells(Rows.Count, "F").End(xlUp).Row

With Workbk.Sheets(sht)
Set rng = .Range("A1:F" & last)
End With

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

With rng
.AutoFilter
.AutoFilter Field:=6, Criteria1:=x.Value
.SpecialCells(xlCellTypeVisible).Copy

newBook.Sheets.Add(After:=Sheets(Sheets.Count)).Name = x.Value
newBook.Activate
ActiveSheet.Paste
End With
Next x

' Turn off filter
Workbk.Sheets(sht).AutoFilterMode = False

With Application
.CutCopyMode = False
.ScreenUpdating = True
End With

End Sub

8. Suppose you want to sum values in each worksheet. The following program sums column B of each worksheet. It also writes 'Total' at last row of column A. It assumes your data starts from column A.

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

Click on the link below to check out the working macro
Download the workbook

Related Link - Filter Data Based on Drop Down Selection

Excel Tutorials : 100 Excel Tutorials

Subscribe to get Email Updates!

Related Posts

About Author:

Deepanshu founded ListenData with a simple objective - Make analytics easy to understand and follow. He has over 8 years of experience in data science. During his tenure, he has worked with global clients in various domains like Banking, Insurance, Telecom and Human Resource.

While I love having friends who agree, I only learn from those who don't
Let's Get Connected: Email | LinkedIn