Excel VBA: How to Filter Data and Copy to New Sheet or Workbook

Deepanshu Bhalla 121 Comments ,

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. It is a very time consuming process if you do it manually. It can be easily done with Excel VBA programming. 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.

The sample data is shown below :

Excel VBA: Filter and Copy Data

Click on the link below to download the working macro file

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 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 above VBA Code
  5. Save the file as Macro Enabled Workbook (xlsm) or Excel 97-2003 Workbook (xls)

In the excel macro, it is assumed a filter is applied on column F (Rank) and data starts from cell A1.

How to Customize the Macro

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. How to filter for a specific value instead of all unique values

Remove the following line of code -


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

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

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

Excel Macro : Filter and Paste Unique Values to New Workbook

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
How to Sum Values in Each Sheet

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  

Excel Macro : Filter and Paste Data to Multiple Workbooks

Incase you want to paste data to multiple workbooks after filtering data. Data for each unique value will be saved in a different workbook with the name same as unique value.

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

'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

' Loop through unique values in column
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

'Add New Workbook in loop
Set newBook = Workbooks.Add(xlWBATWorksheet)

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

'Save new workbook
newBook.SaveAs x.Value & ".xlsx"

'Close workbook
newBook.Close SaveChanges:=False

Next x

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

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

End Sub
You can remove this line of code if you don't want to close the newly created workbooks. newBook.Close SaveChanges:=False
Related Posts
Spread the Word!
Share
About Author:
Deepanshu Bhalla

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

121 Responses to "Excel VBA: How to Filter Data and Copy to New Sheet or Workbook"
  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. Excellent Work :
    Attempted something through record macros but this one is excellent.
    Thank you very much.

    ReplyDelete
  4. 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
  5. 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
    3. Thanks for the code bro...

      Delete
  6. 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
  7. 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
  8. Hi, how can I use this for multiple sheets in a workbook to save all the filtered data in one.
    Thanks.

    ReplyDelete
  9. 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
  10. 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
  11. 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
  12. Thanks it works for me

    ReplyDelete
  13. 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
    Replies
    1. I have the same need. Did you happen to find a solution for it?

      Delete
  14. 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
  15. Can it be added SUM/Total of age column in each worksheet
    For example in worksheet 1
    name age adress contact org rank
    richa 2 iii xyz prst 1
    rekha 1 kkk xyz prst 1
    seeta 1 kkk xyz prst 1
    rahul 6 hhh xyz prst 1
    Total 10

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

    ReplyDelete
  17. Deepanshu,
    Thanks a lot for response,
    Can you please specific the details, as i am unable to search-out the solution (what you have added related to my request i.e. SUM of age column in each sheet for example Total 10, in this post).
    - Ravi

    ReplyDelete
    Replies
    1. See 6th point under 'How to customize the above program'.

      Delete
  18. Yes,
    It's done, thanks a lot SIR
    - Ravi

    ReplyDelete
  19. How do we customize the above code for the filter being one of the columns, say column C ?

    I used the below code, but get an error.

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

    Sheets(sht).Range("C1:C" & last).AdvancedFilter Action:=xlFilterCopy, CopyToRange:=Range("AA1"), Unique:=True'change filter column in the following code
    last = Sheets(sht).Cells(Rows.Count, "C").End(xlUp).Row
    Set rng = Sheets(sht).Range("A1:F" & last)

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



    When I tried, I get the error "The exact range has a missing or illegal field name"

    ReplyDelete
  20. This comment has been removed by the author.

    ReplyDelete
  21. How can this be altered to have Pre-made sheets instead of generated.

    ReplyDelete
  22. hello
    can I customise it to create a new workbook instead?

    ReplyDelete
  23. Hello, I have added the Sheets(x.Text).Delete after
    For Each x In Range([AA2], Cells(Rows.Count, "AA").End(xlUp))
    but I am getting a subscript out of range error on
    Sheets(x.Text).Delete

    ReplyDelete
    Replies
    1. Could you upload your file to cloud and share link with me?

      Delete
    2. Hi,I have uploaded the screenshots here.
      ( https://www.dropbox.com/sh/iar3yh2vl8ro0tl/AAA9gmdgyj2BLxAnb8bQGCvya?dl=0 )

      Delete
    3. By the way, I am using Excel 2016.

      Delete
    4. I have modified the code. Follow the 5th point under "How to Customize the above program". Cheers!

      Delete
    5. Thank you very much, Deepanshu! :)

      Delete
  24. Hi - thanks so much for the code. Is there any way of modifying so that only specific columns are copied and pasted? I have data in columns A-U but only want to copy U, E & F (table format with headers)

    Have been going round in circles so any help much appreciated!

    ReplyDelete
  25. I want to delete sheets when the data is removed, how can I do that?

    ReplyDelete
  26. Hi Bro,

    Your code works Good. I would like to change simply for my requirements. What I try to do is, after the filtering of data, instead of copying the full active data which filtered, I want to copy the D column with only active cells except header and paste it in another sheet parallel with transpose of data

    ReplyDelete
  27. Hello,
    What if I would like to filter the data based on criterias present in 2 different columns ?

    ReplyDelete
  28. Hi Deepa, thanks for sharing this. It is very helpful. One thing, what about if I wanted to have the same cells width and heights as the source. Thanks in advance.

    ReplyDelete
  29. CAN I FILTER THE SAME DATA WITH A COLUMN AS YOU SAID WITH F COLUMN

    ReplyDelete
  30. Great , Simply Awesome. Saved a lot of manual work for me.

    ReplyDelete
  31. Hi Db...code is excellent...it works with no header cell and only raw data. What if I have cell headers in the first two rows and want them copied as well in the new worksheets ? Second question is - I want filtered data with respect to two criteria but the name of the new worksheet is based on only one criteria ?

    ReplyDelete
  32. I came across this code while doing some research for filtering using VBA and it worked perfectly. I would like to know, how would I modify the VBA if I only require a few columns to be copied over into the new worksheet.

    Example: The sheet I am filtering has 10 rows, but I only need to copy data from columns "A,C,D,E,F,H,I,J"

    ReplyDelete
    Replies
    1. I have added it to this tutorial. Refer point #6. Thanks!

      Delete
    2. Much appreciated, thanks.

      Delete
  33. muchas, muchísimas gracias estimado!!, saludos desde Ecuador

    ReplyDelete
    Replies
    1. Me alegra que te haya resultado útil. Aclamaciones

      Delete
  34. Thanks!! absolutely gorgeous. I just needed something and approach like this. All variants are also interesting and very well explained. simple THANKS!!
    Gracias!

    ReplyDelete
  35. My script below works well but I need to tweek it a bit.
    Can you assist me with modifying the below vba.

    1. I do not want to set any cell ranges only column range, so where I have "N1344", how do I change that to just "N" and make the script work?

    2. I need to only copy columns A,C,D,E,F,H,I,J,K,L,M,N from my "Names" worksheet and paste into my "Backlog" worksheet. How do I modify the script to make it run? I tried similar to your #6 above and it didn't work.


    Sub copyFilteredBacklog()
    Dim rng As Range
    Dim autofiltrng As Range
    With Sheets("Names")
    .Range("A1:N1344").AutoFilter field:=11, Criteria1:=">" & Range("N2").Value
    End With
    With Sheets("Names").AutoFilter.Range
    On Error Resume Next
    Set autofiltrng = .Offset(1, 0).Resize(.Rows.Count - 1, 1).SpecialCells(xlCellTypeVisible)
    On Error GoTo 0

    End With
    If autofiltrng Is Nothing Then
    MsgBox "no data available for copying!"
    Else
    Worksheets("Backlog").Range("A7:L1344").ClearContents
    Set rng = Sheets("Names").AutoFilter.Range
    rng.Offset(1, 0).Resize(rng.Rows.Count - 1).Copy Destination:=Sheets("Backlog").Range("A7")
    Range("A7", Range("A7").End(xlDown).End(xlToRight)).Interior.Color = xlNone
    Range("A7", Range("A7").End(xlDown).End(xlToRight)).Font.Color = vbBlack
    End If
    Sheets("Names").ShowAllData
    End Sub

    ReplyDelete
  36. Follow the steps below for your first point -
    1. Add the following code after "Dim autofiltrng As Range" line
    last = Sheets("Names").Cells(Rows.Count, "N").End(xlUp).Row

    2. Replace Range("A1:N1344") with Range("A1:N" & last)

    Can you show me the script for second point where you made changes as suggested above?

    ReplyDelete
    Replies
    1. The below is the script, that copies the data to the "Backlog" sheet. But it copies all columns. I only want to copy columns A,C,D,E,F,H,I,J,K,L,M,N.

      If autofiltrng Is Nothing Then
      MsgBox "no data available for copying!"
      Else
      Worksheets("Backlog").Range("A7:L1344").ClearContents
      Set rng = Sheets("Names").AutoFilter.Range
      rng.Offset(1, 0).Resize(rng.Rows.Count - 1).Copy Destination:=Sheets("Backlog").Range("A7")
      Range("A7", Range("A7").End(xlDown).End(xlToRight)).Interior.Color = xlNone
      Range("A7", Range("A7").End(xlDown).End(xlToRight)).Font.Color = vbBlack
      End If
      Sheets("Names").ShowAllData
      End Sub

      Delete
  37. Hi Deepanshu,

    I am using your code to filter data and paste into a new Workbook. Your code is really helpful. But I am stuck at the below line

    newBook.Sheets.Add(After:=Sheets(Sheets.Count)).Name = x.Value

    Am getting the error - method 'add' of object sheets failed. Below is my modified code. Could you please help me at the earliest?

    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 = "NEWDATA"

    '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, "A").End(xlUp).Row

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

    Workbk.Sheets(sht).Range("A1:A" & 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:=1, 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





    ReplyDelete
  38. Helo, Is it possible to filter and copy data from one sheet and paste it in another but the column heads are different in second workbook. I need to copy from first sheet then paste in to corresponding columns in second work book

    ReplyDelete
  39. Hi the code is working good for me, but I have one requirement instead of copying 4unique sheets I want it for one unique value it should copy in the new sheet, can you please help me and also filter should be defined as one column contains values i.e in positive and in negetive integers and another column has open and closed staus here I want only open status that is with negetive interger.

    ReplyDelete
  40. Hi! Such a helpful thread, probably the most useful I've ever seen. Thank you for posting

    I have tweaked the original VBA code you have provided to suit my spreadsheet (range A to O, filtering on A, Autofilter Field 1 ) but would like to have some code in which the user can input a value from Column A into a box, which then runs the original code to filter for that input, copy and pasta the data into a new workbook.
    I have tried to use other codes from other sits but can't seem to figure this one out!

    Any help would be greatly appreciated!

    ReplyDelete
  41. I am using your code to filter data and paste into a new worksheet. Your code is really helpful. But I am stuck at the below line. I have a filter on F and last is F itself

    "last = Sheets(sht).Cells(Rows.Count, "F").End(xlUp).Row"

    Can you please help me with the change in the below code

    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 = "Datasheet"

    '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

    ReplyDelete
  42. Okay, the above helped beautifully for my project. Now I have another scenario.
    I have 3 workbooks open, on sheet 'Names' from each workbook, I want to clear filter and copypaste the data from all 3 workbooks into another workbook on to sheet 'Data', which already has data in it.

    From the 3 workbooks, sheet 'Names' has data in columns A-N,
    I want to clear filter on the 'Names' tab, if any
    Then copy from column A-N, from all 3
    Clear the filter, if any, in the workbook 'ConNames' sheet 'Data'
    Then add the copied data from all 3 to the next available blank row in workbook 'ConNames' sheet 'Data'

    May you please assist. I want to also add another scenario but need to complete this first. Appreciated

    ReplyDelete
  43. A userform can be used for column copying. The userform contains two listboxes. The column headings on sheet1 are listed on first listbox.In between the list boxes,the item moves from listbox1 to listbox2 by clicking the button. . The selected columns from listbox2 are copied to other sheet (sheet2) with Advanced Filter method.

    Private Sub CommandButton1_Click()
    Dim FirstCell, LastCell As Range
    Dim basliklar As Integer
    Dim baslangic_satiri As Long
    Sheets("report").Select
    If ListBox2.ListCount = 0 Then
    MsgBox "You don't choose filter field "
    Exit Sub
    End If
    ProgressDlg.Show 'Progress Bar

    Set LastCell = Sheets("database").Cells(Sheets("database").Cells.Find(What:="*", SearchOrder:=xlRows, _
    SearchDirection:=xlPrevious, LookIn:=xlValues).Row, _
    Sheets("database").Cells.Find(What:="*", SearchOrder:=xlByColumns, _
    SearchDirection:=xlPrevious, LookIn:=xlValues).Column)
    Set FirstCell = Sheets("database").Cells(Sheets("database").Cells.Find(What:="*", After:=LastCell, SearchOrder:=xlRows, _
    SearchDirection:=xlNext, LookIn:=xlValues).Row, _
    Sheets("database").Cells.Find(What:="*", After:=LastCell, SearchOrder:=xlByColumns, _
    SearchDirection:=xlNext, LookIn:=xlValues).Column)

    For basliklar = 0 To ListBox2.ListCount - 1
    baslangic_satiri = 2
    Sheets("report").Cells(baslangic_satiri - 1, basliklar + 1) = ListBox2.List(basliklar, 0)

    Sheets("database").Range(FirstCell, LastCell).AdvancedFilter _
    Action:=xlFilterCopy, CriteriaRange:=Sheets("database").Range(FirstCell, LastCell), _
    CopyToRange:=Sheets("report").Cells(baslangic_satiri - 1, basliklar + 1), _
    Unique:=False
    Next
    Sheets("report").Columns.EntireColumn.AutoFit
    CommandButton6.Enabled = True
    End Sub

    Example file at here : https://www.technologicaltipstools.online/2015/06/excel-filtering-columns-via-userform.html

    ReplyDelete
  44. Hi,

    I am having trouble getting the codes to work. My data is being filter from row 15 instead of row 1.

    Is there a potential rule that I am missing? I am filtering column D however range from A-F

    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 = "Deductions"

    '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("A15:F" & last)
    End With

    Workbk.Sheets(sht).Range("D15: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

    ReplyDelete
  45. Hello Sir,

    I want to apply filter in excel data and want to copy and paste the data in some other sheet.
    Could you please help me to get the code.

    Regards
    Abhishek

    ReplyDelete
  46. Hi,

    I was having an issue with this line when using the code for "copying data into new workbook" code.


    Workbk.Sheets(sht).Rang("eE1:E" & last).AdvancedFilter Action:=xlFilterCopy, CopyToRange:=Range("AA1"), Unique:=True


    Would you be able to help?


    The code is below:

    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 = "Master Order List"

    '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, "E").End(xlUp).Row

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

    Workbk.Sheets(sht).Rang("eE1:E" & 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


    ReplyDelete
  47. Hi! Thank you so much for such clear explanation. I have tried the code, and it works in my workbook.

    But, I need help about one thing, what if I want to paste the filtered data to an existing sheet (not to a new sheet)..

    Could you (or someone) please explain how is the code going to be?
    Thanks so much!

    ReplyDelete
  48. Hi - can I add my thanks, I have spent hours trying to find out how to do this and this was really helpful. Could I also one question - if I had more complex formula (i.e. Averageifs) under the table of data is there an easy way of copying those so they appeared under the new filtered data?
    Many thanks

    ReplyDelete
  49. Hello Deepanshu,
    Hope you are doing well.
    I've got a question regarding error I receive while using your code. Namely, I receive the error "Run-time error 1004. The extract range has a missing or invalid field name", no matter if I change data within your code to my desired filter or if I just copy and paste your code (changing only name of the tab at the beginning of the code). Dubug feature shows as faulty the same line of the code in all cases.

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

    You support will be much appreciated!
    Thanks!
    Magda

    ReplyDelete
  50. Hello, I a getting "run-time error '1004': Method 'Add of object 'Sheets" failed. Do you have any suggestions?

    I am trying to filter by unique values in Column D, for everything between rows A to P

    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"

    '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, "D").End(xlUp).Row

    With Workbk.Sheets(sht)
    Set rng = .Range("A1:P" & 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:=4, 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

    ReplyDelete
  51. I keep getting a runtime error13 on this line:
    Sheets(WS).Range("AT1:AT" & LastRow1).AdvancedFilter Action:=xlFilterCopy, CopyToRange:=Range("BA1"), Unique:=True

    Can you please assist?

    ReplyDelete
  52. Hello Sir,
    Your macro work fir me greatly, however, i need something more.
    i want the macro to add heading to all tables generated to other sheets. for instance "gleam list for the month of august, 2020" gleam is one of the sheets generated.
    Thank you Sir for your continued assistance.

    ReplyDelete
    Replies
    1. August 2020 should be date of the present month and year

      Delete
  53. thanks bro
    i need more help about find and copy the whole row

    ReplyDelete
  54. This is all super helpful and appreciated! How would the code need to be modified so that the macro generates a separate new workbook for each unique value? This would be super useful if one needs to distribute separate workbooks to multiple people.
    Thank you in advance!

    ReplyDelete
    Replies
    1. Thanks. Code has been added into the article for the same. Refer section 8 for generating a separate new workbook for each unique value. Cheers!

      Delete
  55. Hi sir,
    How to copy data in rows range between first filter to next filter split into worksheet name as filter value.

    Rakesh

    ReplyDelete
  56. Hi DB, many thanks for your query, it works like a charm. How do I send those files as attachment by outlook. Can you add about it in your query?

    ReplyDelete
  57. After working with the above examples I got creative somewhat and wrote the code below. I am copying data from 3 workbooks, all with the same worksheet name, into another workbook on the same worksheet into the next available row.

    I then attempted to filter the 3 workbooks and copy the only the filtered data. That part of the code does not work. It filters the first workbook but then I get an error message on the copy visible cell.

    DO you think anyone here can assist me with fixing my code and sharing where I went wrong?

    Code:

    Option Explicit

    Sub updateCurRevenue()

    Dim sNames As Variant
    sNames = Array("Jax.xlsm", "Trax.xlsm", "Brax.xlsm")

    Dim wb As Workbook
    Set wb = ActiveWorkbook

    With wb.Worksheets("Data")
    Dim dFirst As Range
    Set dFirst = .Cells(.Rows.Count, "A").End(xlUp).Offset(1)
    End With

    Dim dCell As Range
    Set dCell = dFirst

    Dim sName As Variant
    Dim sLastRow As Long
    Dim sRng As Range
    Dim dRows As Long
    Dim i As String
    i = InputBox("Last actual Date")

    For Each sName In sNames
    With Workbooks(sName).Worksheets("Numbers")
    sLastRow = .Cells(.Rows.Count, "A").End(xlUp).Row
    Selection.AutoFilter
    .Range("A2:N" & sLastRow).AutoFilter field:=12, Criteria1:=">" & i
    Set sRng = .SpecialCells(xlCellTypeVisible).Copy
    sRng.Autofiltermode = False
    End With

    With sRng
    dCell.Resize(.Rows.Count, .Columns.Count).Value = sRng.Value
    dRows = dRows + .Rows.Count
    Set dCell = dCell.Offset(.Rows.Count)
    End With
    Next sName
    With dFirst.Resize(dRows, sRng.Columns.Count)
    .Interior.Color = xlNone
    With .Font
    .Name = "Arial"
    .Size = 10
    End With
    End With

    ReplyDelete
  58. Thanks for the code. i tried to run it and it creates the sheets as per the column but it doesnt copy the rest of the data, i get blank sheets with just the headers. Can you please help.

    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 last As Long
    Dim sht As String
    Dim cnt As Long
    'specify sheet name in which the data is stored
    sht = "Eligibility - Landing"

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

    Sheets(sht).Range("L1:L" & 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:=11, Criteria1:=x.Value
    .SpecialCells(xlCellTypeVisible).Copy
    cnt = cnt + 1
    Sheets.Add(After:=Sheets(Sheets.Count)).Name = Left(x.Value, 27) & cnt

    ActiveSheet.Paste
    End With
    Next x

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

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

    End Sub


    ReplyDelete
  59. Hi I need help with the following:
    Is it possible to tweak this code for pivots?
    Is it possible to change file save location?
    An extra sheet is added instead of overwriting Sheet 1 which adds an extra step to delete that sheet as they need to be shared with the team, is it possible to delete that
    The data is highlighted, is it possible to code it so as it goes to cell A1 after pasting

    I would really appreciate your help with all this

    ReplyDelete
  60. Hi DB,

    Firstly your code is very useful, i really appreciate it.

    I am using your code and i have made a small customization. I already have a macro that creates the worksheets in my workbook with the unique values from the filter criteria, however when i use your code to paste unique values after a filter criteria into the sheet with the criteria value name, it is pasting the unique values of the next "x" criteria. Please could you assist me so that for each criteria it pastes the values into the sheet name with is equal to the criteria. Please see your code i have modified below:

    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

    Worksheets(x.Value).Activate
    ActiveSheet.Paste
    End With
    Next x

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

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

    End Sub


    I look forward to your response.

    ReplyDelete
  61. Is there a way to paste everything into a single sheet?

    ReplyDelete
  62. Is there a way to paste everything into a single sheet?

    ReplyDelete
  63. Hi there, just wondering what code I would need to add/amend to ensure each new workbook I am saving doesn't contain a "Sheet 1", in addition to the sheet containing the filtered data? I need to import the data and the sheet containing the filtered data must be the only sheet in the workbook.
    Thank you.

    ReplyDelete
  64. If Not GetWorksheet(x.Text) Is Nothing Then
    Sheets(x.Text).Delete
    End If
    Hi, when we re-execute the macro, for deletion of every sheet, confirmation is being asked. How to make it to delete all sheets without delete confirmation message

    ReplyDelete
  65. Thanks for a very useful blog!

    Suggest to modify this line to run the code multiple times when data is copied to another workbook, otherwise Error 1004 is thrown as VBA can't get the correct reference of Data sheet without explicitly providing the sheet reference in Range formula -
    "For Each x In Range([AA2], Cells(Rows.Count, "AA").End(xlUp))" requires the reference of the workbook and sheet in Range parameters.

    Updated -
    "For Each x In Range(Workbk.Sheet(sht).[AA2], Cells(Workbk.Sheet(sht).Rows.Count, "AA").End(xlUp))"

    Above works perfectly with multiple runs.

    ReplyDelete
  66. Hi DB,

    Your code worked great initially but now has stopped working. Not sure what is wrong. I have the filter in column B. Also how do I change the code to select only one value (instead of all the unique values) and then transfer to a specific existing workbook to an existing blank worksheet including headers. I initiate your code using a button and next to the button is a drop down list with unique values for Column B. I want your code to match the value selected in the dropdown and then send only that data across. Thanks a million in advance.

    Below is the code that I currently have (basically your code)

    Sub moveData()
    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 = "Sales"

    '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, "B").End(xlUp).Row

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

    Workbk.Sheets(sht).Range("B1:B" & 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:=2, Criteria1:=x.Value
    .SpecialCells(xlCellTypeVisible).Copy
    newBook.Activate
    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

    ReplyDelete
    Replies
    1. Refer fifth point to fix this - "Your code worked great initially but now has stopped working. Not sure what is wrong"

      Delete
    2. Also refer 10th point on how to select only one value (instead of all the unique values)

      Delete
    3. DB - you are too good. Your script is working again and I could transfer only one customer's data to a new workbook.

      Can you help me with the second part of my request. On my formatData worksheet I have a dropdown list along with a MoveData button. I want to select one of my customers from this dropdown list and then hit the MoveData button. This should transfer the data for only that specific customer to an existing workbook (Dashboard) and to sheet (SalesOrders). If possible, I would prefer not to use AA2 to manually fill up the field.

      Delete
    4. Forgot to mention - After data has been transferred to the destination workbook (Dashboard.xlsm), I would like it to automatically be save in the same folder as 'Customer1_Dashboard_DateTime'.xlsm

      Delete
    5. Below is the code that I have till now. It selects value from dropdown list and then filters based on it. Then copies the range to newBook. First clears any old data in SalesOrder worksheet. But fails at ActiveSheet.Paste with runtime 1004 error.

      Sub moveDataTest1()
      Application.ScreenUpdating = False
      Dim x As Range
      Dim rng As Range
      Dim last As Long
      Dim sht, shtButtons, CustName, PathOnly, destSht, newFile As String
      Dim newBook As Excel.Workbook
      Dim Workbk As Excel.Workbook


      PathOnly = ThisWorkbook.Path
      newFile = "SalesDashboard.xlsm"
      'Specify sheet name in which the data is stored
      sht = "Sales"
      shtButton = "Buttons"
      'Specify destination sheet name
      destSht = "SalesOrder"

      'Workbook where VBA code resides
      Set Workbk = ThisWorkbook
      Workbk.Activate

      With Workbk.Sheets(shtButton)
      Set x = .Range("H6")
      End With

      'Filter based on Customer Name in Column B
      last = Workbk.Sheets(sht).Cells(Rows.Count, "B").End(xlUp).Row

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

      With rng
      .AutoFilter
      .AutoFilter Field:=2, Criteria1:=x.Value
      .SpecialCells(xlCellTypeVisible).Copy
      Set newBook = Workbooks.Open("D:\Personal\SalesDashboard.xlsm")
      newBook.Activate
      newBook.Worksheets(destSht).Activate
      Selection.Delete Shift:=xlUp
      ActiveSheet.Paste
      End With


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

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

      Delete
  67. This code works brilliantly well with the modification that you have suggested.
    It creates four different sheets based on the selection (as I have four unique options) but I want to change the code so that two unique values are selected and are pasted in one sheet and rest two are pasted in other sheet, that is the values are distributed in two different sheets. Any help in this regard would be appreciated.

    ReplyDelete
  68. thanks for the code, it worked brilliantly for but i need the code to copy just two column to the new created sheets instead of all the columns i.e. Column A, and Column H in my case. Below is the VBA code i use.

    Sub FilterToWorkbooks()
    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 = "Sheet1"

    'Workbook where VBA code resides
    Set Workbk = ThisWorkbook

    '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:H" & last)
    End With

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

    ' Loop through unique values in column
    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

    'Add New Workbook in loop
    Set newBook = Workbooks.Add(xlWBATWorksheet)

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

    'Save new workbook
    newBook.SaveAs x.Value & ".xlsx"

    'Close workbook
    newBook.Close SaveChanges:=False

    Next x

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

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

    End Sub

    ReplyDelete
    Replies
    1. Refer point 6 under "How to Customize the above program"

      Delete
  69. thank you for your quick response, your above vba copied filtered data to new workbooks from column A:H which it did well, i want it to copy just 3 column of the filtered data to the new workbooks i.e. Column A, C,& H instead of sheets i posted earlier.
    Thanks once more

    ReplyDelete
    Replies
    1. Did you refer what I suggested in my previous comment?

      Delete
  70. Yes i tried it but it doesn't work, when I debug it highlighted AutoFilter Field:=6, Criteria1:=x.Value.

    Also the vba saved d files in my documents, is it possible for it to create a folder using system month and year and paste it in it (feb 2022, for instance) since I run it once monthly.
    Thanks for your prompt response

    ReplyDelete
    Replies
    1. The highlighted line "AutoFilter Field:=6, Criteria1:=x.Value" filters data, not copying specific columns. May be issue specific to your data. Try the program shown in Point 6 and see if it's working on different data.

      Delete
    2. this the code after applying point 6, it copied all the filtered column (A:H) instead of column C & H, please kindly help me out as i've look through all your points but finds it applicable to sheets and not copying to multiple workbooks.
      thank you always for your help Deepanshu Bhalla


      Sub FilterToWorkbooks()
      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 = "Sheet1"

      'Workbook where VBA code resides
      Set Workbk = ThisWorkbook

      '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:H" & last)
      Set rng1 = Union(.Range("C1:C" & last), .Range("H1:H" & last))
      End With

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

      ' Loop through unique values in column
      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

      'Add New Workbook in loop
      Set newBook = Workbooks.Add(xlWBATWorksheet)

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

      'Save new workbook
      newBook.SaveAs x.Value & ".xlsx"

      'Close workbook
      newBook.Close SaveChanges:=False

      Next x

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

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

      End Sub

      Delete
    3. It's because you are copying everything as you are not making use of "rng1". Don't use this ".SpecialCells(xlCellTypeVisible).Copy". Focus on the following code in Point 6.

      With rng
      .AutoFilter
      .AutoFilter Field:=6, Criteria1:=x.Value
      End With

      With rng1
      .SpecialCells(xlCellTypeVisible).Copy

      Delete
    4. Thanks a million, it worked perfectly as i wanted. I'm so excited and grateful.
      But one more thing, i want d macro to create a folder in drive c using system date - month and year (eg
      Mar 2022) and paste the workbook in it.

      Delete
  71. This is really helpful! I am using the code from step 9 but since I am using this on new files every time the macro will live in the personal workbook. When I run the macro while it's saved in the file it works perfectly but when I run it from the personal workbook I get a runtime 1004 application/object defined error on line-
    For Each x In Workbk.Sheets(sht).Range([W2], Cells(Rows.Count, "W").End(xlUp))

    Can you help with pointing out what needs to change so the macro can be used while saved in personal workbook?

    Thanks in advance!

    ReplyDelete
    Replies
    1. If anyone else runs into this issue it was a simple fix I just changed the code in the following line from ThisWorkbook to ActiveWorkbook

      'Workbook where VBA code resides
      Set Workbk = ThisWorkbook

      Delete
  72. Thanks for the code and is working as expected
    I'm trying to wrap my head around these two lines(I know you mentioned unique values are copied to AA).
    but what's going on with ranges AA1 and AA2.
    From my understanding unique values are copied to AA1 i,e CopyToRange:=Range("AA1")
    How did unique values wound up in 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))


    Thanks in advance

    ReplyDelete
    Replies
    1. AA1 stores first unique value which is header of column F. AA2 contains second unique value i.e. First "desired" unique value. Hope it makes sense

      Delete
    2. That was really embarrassing I thought AA1 was column instead of first row in column AA.Thanks for the reply

      Delete
  73. Hi! Thank you for putting this together for the community. In my case, if there's only one variable in the filter by column I need the program to abort. Could you or someone else please provide the additional lines of code for this exception? TY!

    ReplyDelete
  74. Hi, this works amazingly, but how do you mash up points 8 and 9? And also erase sheet1 from the new files if possible.

    ReplyDelete
  75. Hi Deepanshu, thank you for sharing this amazing timesaving work.

    May I ask you guidance with a little tweak on the code please, I have tried hard to make some changes in the code but nothing is working out for me.
    What I do is, I replace the master data each time before I run the file because I have the existing sheets with templates saved there & I need to use that specific format to publish the new & replaced data to the stakeholders. More like each time clearing master data & dumping the new data in master file so I can generate latest vouchers at each sheet(x).

    Please note that the master data is dynamic when it comes to number of rows.
    So I need guidance for below three tweaks, please help,
    1: Is it possible to start a clear content command which clears old content from each sheet(x) at range "B27:E36"?
    2: after clearing old data, the new filtered data from columns “B:E” at Masterfile to auto-filtered for each x & be pasted(paste special values only) at the same range on each Sheet(x) @ “B27:E36”.
    3: Don’t need to add new sheets Automatically, it’s best if I get the debug error so I can notice that a new sheet needs to be added before I re-run the macro again.

    Thank you once again for your time and effort which makes alot of lives easier :)

    ReplyDelete
  76. Hi Deepanshu, thank you for sharing this amazing timesaving work.

    May I ask you guidance with a little tweak on the code please, I have tried hard to make some changes in the code but nothing is working out for me.
    What I do is, I replace the master data each time before I run the file because I have the existing sheets with templates saved there & I need to use that specific format to publish the new & replaced data to the stakeholders. More like each time clearing master data & dumping the new data in master file so I can generate latest vouchers at each sheet(x).

    Please note that the master data is dynamic when it comes to number of rows.
    So I need guidance for below three tweaks, please help,
    1: Is it possible to start a clear content command which clears old content from each sheet(x) at range "B27:E36"?
    2: after clearing old data, the new filtered data from columns “B:E” at Masterfile to auto-filtered for each x & be pasted(paste special values only) at the same range on each Sheet(x) @ “B27:E36”.
    3: Don’t need to add new sheets Automatically, it’s best if I get the debug error so I can notice that a new sheet needs to be added before I re-run the macro again.


    Thank you once again for your time & efforts which is making our worklives alot easier.

    ReplyDelete
Next → ← Prev