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 :
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
- Open an Excel Workbook
- Press Alt+F11 to open VBA Editor
- Go to Insert Menu >> Module
- In the module, paste the above VBA Code
- 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.
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
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
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
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.
ReplyDeleteSuperb work.
ReplyDeletePeople use to just provide simple code not explain modification for code. but you did that make you good guide. three claps for you.
Excellent Work :
ReplyDeleteAttempted something through record macros but this one is excellent.
Thank you very much.
Thank you for stopping by my blog!
DeleteI LOVE IT!!
ReplyDeleteThank you so much
THANK U SO MUCH
ReplyDeleteI 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.
ReplyDeleteSub 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
I got it to work!!! Thank you!!! The issue was with one of the values I filtered; the characters exceeded the max of 30.
ReplyDeleteGlad to know it's working for you. Thanks!
DeleteHi 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.
DeleteSub 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
Thanks for the code bro...
DeleteI am getting the following error.
ReplyDeleteruntime error 9 subscript out of range
I am getting the error at line
"last = Sheets(sht).Cells(10, "D").End(xlUp).Row"
I have the same problem :/
DeleteSame. Has anyone figured this out?
DeleteCan any one help me to resolve it. Thank you for your help in advance.
ReplyDeleteHave 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.
DeleteHi, how can I use this for multiple sheets in a workbook to save all the filtered data in one.
ReplyDeleteThanks.
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
ReplyDeleteIt works. Did you follow the instruction properly? What error you are getting?
DeleteHelo mr DB...
ReplyDeleteyour 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..?
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.
Deletehi deepanshu,
ReplyDeletefrom 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
Thanks it works for me
ReplyDeleteHi Deepanshu...
ReplyDeleteIts 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
I have the same need. Did you happen to find a solution for it?
DeleteHi, 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?
ReplyDeleteYou can use the follow code instead of activesheet.paste -
DeleteActiveSheet.Range("a1").PasteSpecial Paste:=xlFormulas
Can it be added SUM/Total of age column in each worksheet
ReplyDeleteFor 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
Can any one help me to resolve it. Thank you for your help in advance
ReplyDeletePlease help
ReplyDeleteI have added solution in the post. Hope it helps!
DeleteDeepanshu,
ReplyDeleteThanks 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
See 6th point under 'How to customize the above program'.
DeleteYes,
ReplyDeleteIt's done, thanks a lot SIR
- Ravi
Thank you so much
ReplyDeleteHow do we customize the above code for the filter being one of the columns, say column C ?
ReplyDeleteI 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"
I'm having the same issue...
DeleteHow can this be altered to have Pre-made sheets instead of generated.
ReplyDeletehello
ReplyDeletecan I customise it to create a new workbook instead?
Hello, I have added the Sheets(x.Text).Delete after
ReplyDeleteFor 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
Could you upload your file to cloud and share link with me?
DeleteHi,I have uploaded the screenshots here.
Delete( https://www.dropbox.com/sh/iar3yh2vl8ro0tl/AAA9gmdgyj2BLxAnb8bQGCvya?dl=0 )
By the way, I am using Excel 2016.
DeleteI have modified the code. Follow the 5th point under "How to Customize the above program". Cheers!
DeleteThank you very much, Deepanshu! :)
DeleteHi - 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)
ReplyDeleteHave been going round in circles so any help much appreciated!
I want to delete sheets when the data is removed, how can I do that?
ReplyDeleteHi Bro,
ReplyDeleteYour 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
Hello,
ReplyDeleteWhat if I would like to filter the data based on criterias present in 2 different columns ?
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.
ReplyDeleteCAN I FILTER THE SAME DATA WITH A COLUMN AS YOU SAID WITH F COLUMN
ReplyDeleteANYWAY YOU DONE A GREAT JOB...
ReplyDeleteGreat , Simply Awesome. Saved a lot of manual work for me.
ReplyDeleteHi 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 ?
ReplyDeleteI 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.
ReplyDeleteExample: 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"
I have added it to this tutorial. Refer point #6. Thanks!
DeleteMuch appreciated, thanks.
Deletemuchas, muchÃsimas gracias estimado!!, saludos desde Ecuador
ReplyDeleteMe alegra que te haya resultado útil. Aclamaciones
DeleteThanks!! absolutely gorgeous. I just needed something and approach like this. All variants are also interesting and very well explained. simple THANKS!!
ReplyDeleteGracias!
Glad you found it helpful. Cheers!
DeleteMy script below works well but I need to tweek it a bit.
ReplyDeleteCan 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
Follow the steps below for your first point -
ReplyDelete1. 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?
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.
DeleteIf 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
Hi Deepanshu,
ReplyDeleteI 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
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
ReplyDeleteHi 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.
ReplyDeleteHi! Such a helpful thread, probably the most useful I've ever seen. Thank you for posting
ReplyDeleteI 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!
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
ReplyDelete"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
Okay, the above helped beautifully for my project. Now I have another scenario.
ReplyDeleteI 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
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.
ReplyDeletePrivate 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
Hi,
ReplyDeleteI 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
Hello Sir,
ReplyDeleteI 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
Hi,
ReplyDeleteI 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
Hi! Thank you so much for such clear explanation. I have tried the code, and it works in my workbook.
ReplyDeleteBut, 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!
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?
ReplyDeleteMany thanks
Hello Deepanshu,
ReplyDeleteHope 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
Hello, I a getting "run-time error '1004': Method 'Add of object 'Sheets" failed. Do you have any suggestions?
ReplyDeleteI 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
I keep getting a runtime error13 on this line:
ReplyDeleteSheets(WS).Range("AT1:AT" & LastRow1).AdvancedFilter Action:=xlFilterCopy, CopyToRange:=Range("BA1"), Unique:=True
Can you please assist?
Hello Sir,
ReplyDeleteYour 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.
August 2020 should be date of the present month and year
Deletethanks bro
ReplyDeletei need more help about find and copy the whole row
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.
ReplyDeleteThank you in advance!
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!
DeleteHi sir,
ReplyDeleteHow to copy data in rows range between first filter to next filter split into worksheet name as filter value.
Rakesh
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?
ReplyDeleteAfter 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.
ReplyDeleteI 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
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.
ReplyDeleteFunction 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
Hi I need help with the following:
ReplyDeleteIs 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
Hi DB,
ReplyDeleteFirstly 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.
Is there a way to paste everything into a single sheet?
ReplyDeleteIs there a way to paste everything into a single sheet?
ReplyDeleteHi 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.
ReplyDeleteThank you.
If Not GetWorksheet(x.Text) Is Nothing Then
ReplyDeleteSheets(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
Thanks for a very useful blog!
ReplyDeleteSuggest 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.
Hi DB,
ReplyDeleteYour 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
Refer fifth point to fix this - "Your code worked great initially but now has stopped working. Not sure what is wrong"
DeleteAlso refer 10th point on how to select only one value (instead of all the unique values)
DeleteDB - you are too good. Your script is working again and I could transfer only one customer's data to a new workbook.
DeleteCan 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.
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
DeleteBelow 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.
DeleteSub 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
This code works brilliantly well with the modification that you have suggested.
ReplyDeleteIt 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.
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.
ReplyDeleteSub 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
Refer point 6 under "How to Customize the above program"
Deletethank 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.
ReplyDeleteThanks once more
Did you refer what I suggested in my previous comment?
DeleteYes i tried it but it doesn't work, when I debug it highlighted AutoFilter Field:=6, Criteria1:=x.Value.
ReplyDeleteAlso 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
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.
Deletethis 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.
Deletethank 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
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.
DeleteWith rng
.AutoFilter
.AutoFilter Field:=6, Criteria1:=x.Value
End With
With rng1
.SpecialCells(xlCellTypeVisible).Copy
Thanks a million, it worked perfectly as i wanted. I'm so excited and grateful.
DeleteBut 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.
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-
ReplyDeleteFor 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!
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
Delete'Workbook where VBA code resides
Set Workbk = ThisWorkbook
Thanks for the code and is working as expected
ReplyDeleteI'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
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
DeleteThat was really embarrassing I thought AA1 was column instead of first row in column AA.Thanks for the reply
DeleteHi! 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!
ReplyDeleteHi, this works amazingly, but how do you mash up points 8 and 9? And also erase sheet1 from the new files if possible.
ReplyDeleteHi Deepanshu, thank you for sharing this amazing timesaving work.
ReplyDeleteMay 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 :)
Hi Deepanshu, thank you for sharing this amazing timesaving work.
ReplyDeleteMay 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.