AutoFilter Multiple Sheets, Copy, New Book, Paste to Multiple Sheets

bpdarrow · Mar 27th 2020

Here is my dilemma. I have a master workbook with 5 sheets. Each sheet contains a different data-set, but will be filtered by a "Dealer Code" criteria that is common to all 5 sheets. This "Dealer Code" criteria is Column A in all 5 sheets. My goal is to apply autofilter to all 5 sheets, insert a dealer code criteria into a filter input box, copy the filtered data from each sheet, create a new workbook, prompt the Save As dialog box to open, and then paste the filtered data into 5 new sheets. I've had limited success with copying 1 tab and performing the rest of the functions, but not with all 5. I can get all 5 to paste to 1 new book and sheet, but I'm stuck here.

Code

Sub AutoFilter_IHS()
Dim My_Range As Range
Dim FilterCriteria As String
Dim rng As Range
Dim sheetName As String
Dim newBook As Excel.Workbook
Dim Ws As Worksheet
Dim i As Long
Dim bFileSaveAs As Boolean
Application.ScreenUpdating = False
For Each Ws In ThisWorkbook.Worksheets
Set My_Range = Range("A1:Z" & LastRow(ActiveSheet))
My_Range.Parent.Select
My_Range.Parent.AutoFilterMode = False
Exit For
Next
For Each Ws In ThisWorkbook.Worksheets
Set My_Range = Range("A1:Z" & LastRow(ActiveSheet))
FilterCriteria = InputBox("Enter Dealer Code", "Dealer Selection")
My_Range.AutoFilter Field:=1, Criteria1:="=" & FilterCriteria
Exit For
Next
Workbooks.Add
bFileSaveAs = Application.Dialogs(xlDialogSaveAs).Show
If Not bFileSaveAs Then MsgBox "User Cancelled", vbCritical
My_Range.Parent.AutoFilter.Range.Copy
Selection.PasteSpecial Paste:=xlPasteAll
Application.ScreenUpdating = True
End Sub

Display More

bpdarrow · Mar 27th 2020

This is the script that I'm having more success with. It runs perfect, but I can't figure out how to tell it to create new sheets in the new workbook and paste the appropriate data into the new sheets.

bpdarrow · Mar 27th 2020

Ok Final version of script. It works all the way through, but is dependent on specific file names to activate workbooks to copy and then paste the data to.

**royUK** · Mar 28th 2020

Please read the Forum Rules then you will understand why I have added code tags to your first post.

Can you attach an example workbook

bpdarrow · Mar 28th 2020

Hi Roy, thanks for response. Apologies for not posting code in the correct place. I'm trying to go back and edit my original message to remove it, but having trouble. I've also included an example of one of the master files that I'm working with (there are 9 total master files). Also a .txt file with the script that I was able to get working to do what I was trying, but it seems cumbersome and is reliant on two file names (that will in reality be different every time) to function.

**royUK** · Mar 28th 2020

I've added Code Tags for you.

I'll take a look tomorrow for you.

**royUK** · Mar 29th 2020

I think this does all you want

Code

Option Explicit
Sub FilterAndExport()
Dim oWb As Workbook, oNewWb As Workbook
Dim oWs As Worksheet
Dim rRng As Range
Dim iX As Integer
Dim sCode As String, vNewname
Set oNewWb = ActiveWorkbook
''///create new workbook
Set oNewWb = Workbooks.Add
''///add 5 sheets
Application.SheetsInNewWorkbook = 5
sCode = InputBox("Enter Dealer Code", "Filter Criteria")
If sCode = Empty Then
MsgBox "No code entered.", vbCritical, "User cancelled"
ActiveWorkbook.Close False
Exit Sub
End If
iX = 1
For Each oWs In ThisWorkbook.Worksheets
With oWs
If Not .AutoFilterMode Then .Range("A1").AutoFilter
.Range("A1").AutoFilter Field:=1, Criteria1:=sCode
''///set a range = to visible cells (excluding the header)
Set rRng = .AutoFilter.Range
rRng.Copy
With oNewWb
.Sheets(iX).Range("A1").PasteSpecial xlAll
.Sheets(iX).Range("A1").CurrentRegion.Cells.WrapText = False
.Sheets(iX).Range("A1").CurrentRegion.Columns.AutoFit
.Sheets(iX).Name = oWs.Name
End With
iX = iX + 1
End With
Next oWs
vNewname = Application.GetSaveAsFilename
If vNewname <> False Then ActiveWorkbook.SaveAs Filename:=vNewname, FileFormat:=51
End Sub

Display More

bpdarrow · Mar 29th 2020

Thanks for the quick reply! When I run it, I'm getting "Run-time error '1004': AutoFilter method of Range class failed" @ line 26. Is it trying to autofilter the new workbook, or the source workbook?

**royUK** · Mar 29th 2020

No error at all for me. I've run it several times.

The AutoFilter takes place in the original workbook

Are you using the same example workbook? Does each sheet have data starting in A1?

Line 26 checks if AutoFilter is on, if it isn't then it switches it on, if there is no data in A1 then it will error

Code

If Not .AutoFilterMode Then .Range("A1").AutoFilter

bpdarrow · Mar 29th 2020

I downloaded the file that I uploaded here just in case and ran it again. Still get that error, debug takes me to this part of of the autofilter line 26. When it stops running, it's stopped on the new open workbook that doesn't have any data in it yet. Do I need to set a range? I just copied/pasted into a new module as you had it.

Code

.Range("A1").AutoFilter

**royUK** · Mar 29th 2020

I cannot replicate that error. I've run the code successfully twice since my last reply

Just run it again with no errors and noticed that in total I have run it 33 times without that error.

Where have you put the code?

Attach the file that has the code in it

bpdarrow · Mar 29th 2020

Well, I just got it to work. I'm 100% it's my fault - just working through it now. I originally inserted a module to my PERSONAL.XLSB file and pasted your code there. Then I opened the file that I put in here. Then ran it, and that's where I got the error. After your last reply, I opened the sample file and saved it as XLSM rather than XLSX. I inserted a module to the new XLSM version, and pasted the code into the new module. Then I ran it - and it worked. Is the issue because the macro is stored in the XLSB workbook? Must it be stored in the master file?

**royUK** · Mar 29th 2020

The code isn't written for an addin or PERSONAL.xlsb, it was written to run from the source workbook,

I can make adjustments for you.

**royUK** · Mar 29th 2020

This should work from your personal workbook

Code

Option Explicit
Sub FilterAndExport()
Dim oWb As Workbook, oNewWb As Workbook
Dim oWs As Worksheet
Dim rRng As Range
Dim iX As Integer
Dim sCode As String, vNewname
On Error GoTo exit_proc
Application.ScreenUpdating = False
''/// the activeworkbook must be the original data workbook
Set oWb = ActiveWorkbook
''///create new workbook
Set oNewWb = Workbooks.Add
''///add 5 sheets
Application.SheetsInNewWorkbook = 5
sCode = InputBox("Enter Dealer Code", "Filter Criteria")
If sCode = Empty Then
MsgBox "No code entered.", vbCritical, "User cancelled"
ActiveWorkbook.Close False
Exit Sub
End If
iX = 1
For Each oWs In oWb.Worksheets
With oWs
If Not .AutoFilterMode Then .Range("A1").AutoFilter
.Range("A1").AutoFilter Field:=1, Criteria1:=sCode
Set rRng = .AutoFilter.Range
rRng.Copy
With oNewWb
.Sheets(iX).Range("A1").PasteSpecial xlAll
.Sheets(iX).Range("A1").CurrentRegion.Cells.WrapText = False
.Sheets(iX).Range("A1").CurrentRegion.Columns.AutoFit
.Sheets(iX).Name = oWs.Name
End With
iX = iX + 1
End With
Next oWs
vNewname = Application.GetSaveAsFilename
If vNewname <> False Then ActiveWorkbook.SaveAs Filename:=vNewname, FileFormat:=51
exit_proc:
Application.ScreenUpdating = True
End Sub

Display More

bpdarrow · Mar 29th 2020

I see, that's my fault. I should have added that in my original post. So I have 9 source workbooks that are updated monthly with new data. The idea is to store the macro in Personal.XLSB so that it can be run with any source file. The files contain the dealer data by region, and the "dealer code" filter criteria will be specific to whichever region that store is located. Once the data for the specific dealer code is added to a new workbook, I have then recorded formatting macros for each of the 5 sheets. Can the formatting macros be added to this filter and export code? Or is it better to run them separately?

**royUK** · Mar 29th 2020

Your formatting macros will slow the code down, my code copies formats from the original sheet. I thought they looked the same.

bpdarrow · Mar 29th 2020

You are amazing. I've been trying to learn this all from scratch in the last week or so. THANK YOU so much for your help.

**royUK** · Mar 29th 2020

Pleased to help. Does it work OK now?

bpdarrow · Mar 29th 2020

It works PERFECTLY. I'm amazed. Truly amazed.

**royUK** · Mar 29th 2020

You won't learn in a week or so, but just keep on trying and asking questions, especially if you do not understand something in the code that you see.

Share

Tags