Excel VBA : Filtering and copy pasting to new sheet

Suppose you are asked to apply filter on a column and paste result of a filter into a new worksheet 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 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, add the following line of code after 'For Each x In Range([AA2], Cells(Rows.Count, "AA").End(xlUp))'. Caution : It removes the existing worksheets.
Sheets(x.Text).Delete
 Click on the link below to check out the working macro
Download the workbook

Excel Tutorials : 100 Excel Tutorials

Get Free Email Updates :
*Please confirm your email address by clicking on the link sent to your Email*

Related Posts:

24 Responses to "Excel VBA : Filtering and copy pasting to new sheet"

  1. This macro works great for me. I am using it to filter into to 1700 stores! I would like to know how to add an additional part for the new sheet names such as my filtered value & a lookup value for that number for example if store 11111 was in district 1 I would want the name of the new sheet to be 11111 - 1.

    ReplyDelete
  2. Superb work.
    People use to just provide simple code not explain modification for code. but you did that make you good guide. three claps for you.

    ReplyDelete
  3. Santhosh Bandela15 August 2016 at 23:23

    Excellent Work :
    Attempted something through record macros but this one is excellent.
    Thank you very much.

    ReplyDelete
  4. I LOVE IT!!
    Thank you so much

    ReplyDelete
  5. I keep getting an error on Sheets.Add(After:=Sheets(Sheets.Count)).Name = x.Value. I'm filtering column B and have data through column K.
    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 = "report"

    'change filter column in the following code
    last = Sheets(sht).Cells(Rows.Count, "B").End(xlUp).Row
    Set rng = Sheets(sht).Range("A1:K" & last)

    Sheets(sht).Range("B1:B" & 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:=2, 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

    ReplyDelete
  6. I got it to work!!! Thank you!!! The issue was with one of the values I filtered; the characters exceeded the max of 30.

    ReplyDelete
    Replies
    1. Glad to know it's working for you. Thanks!

      Delete
    2. Hi DB - It's not working for me. I know I'm close to your code but would appreciate your help. I'm filtering on Col. F and my data is till col. V.

      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 = "200012-MR09"

      'change filter column in the following code
      last = Sheets(sht).Cells(Rows.Count, "F").End(xlUp).Row
      Set rng = Sheets(sht).Range("A1:V" & 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


      Delete
  7. I am getting the following error.
    runtime error 9 subscript out of range
    I am getting the error at line
    "last = Sheets(sht).Cells(10, "D").End(xlUp).Row"

    ReplyDelete
  8. Can any one help me to resolve it. Thank you for your help in advance.

    ReplyDelete
    Replies
    1. Have you specified your sheet name in this part of the code : sht = "DATA Sheet"? If yes, please save your file in the cloud drive and share the link with me to debug the code.

      Delete
  9. Hi, how can I use this for multiple sheets in a workbook to save all the filtered data in one.
    Thanks.

    ReplyDelete
  10. It is not working. reason i need to filter data from certain col. and then paste the whole sheet in another worksheet. In above code you have pasted in col. AA and that too data for col. F onlt.thanks

    ReplyDelete
    Replies
    1. It works. Did you follow the instruction properly? What error you are getting?

      Delete
  11. Helo mr DB...
    your code is work very well on the first time. But, when i ran twice or more, it gets error, I thinks its because the sheet with the same name already added. How to solve this..?

    ReplyDelete
    Replies
    1. Add Sheets(x.Text).Delete after this line of code 'For Each x In Range([AA2], Cells(Rows.Count, "AA").End(xlUp))'. Hope it helps.

      Delete
  12. hi deepanshu,
    from the above data i would like filter each and every column with some condition then how it will be, in the above you filtered only f column right but i wanted to filter in each and every column with some specific condition, could pls tell me the code

    ReplyDelete
  13. Thanks it works for me

    ReplyDelete
  14. Hi Deepanshu...

    Its great job you have done above... I found it very useful. Thank you very much for that.. I loved it... I wanted to make some small modification as per my requirements. Instead of creating new sheets in the same workbook, i want to create new workbook and copy the same data.. and name it in the same way as you did for worksheets... How can I do that..??

    TYIA
    Amaresh.A.R

    ReplyDelete
  15. Hi, thanks this is great. Would you perhaps know what to change the activesheet.paste to to be able to paste the formulas instead of the values?

    ReplyDelete
    Replies
    1. You can use the follow code instead of activesheet.paste -
      ActiveSheet.Range("a1").PasteSpecial Paste:=xlFormulas

      Delete

Next → ← Prev