Excel VBA filter multiple sheets on name and save as a seperate file

db2020

New Member
Joined
Jun 6, 2021
Messages
9
Office Version
  1. 365
  2. 2010
Platform
  1. Windows
I have a report with 4 worksheets: 1 frontpage and 3 worksheets that have to be filtered on a name. Once filtered, the sheets have to be saved as a seperate file.
I am using the following code now (see below), but I have some questions:
  1. How do I remove the data that does not meet the criteria? So when the data is filtered on Name1, all other Names should be removed.
  2. How do I copy the frontpage (sheet1) together with the 3 filtered sheets into 1 file? It now only copies the 3 filtered sheets.
  3. How do I paste the data as values (it's pasted as formula now)?
VBA Code:
Option Explicit

Sub AutoFilters()
Dim sheetsToFilter As Variant, sheetName As Variant
Dim sheetsColumnToFilterOn As Variant
Dim criteria As Variant, criterium As Variant
Dim iSht As Long
Dim pre As String

sheetsToFilter = Array("Sheet2", "Sheet3", "Sheet4")
sheetsColumnToFilterOn = Array(2, 3, 4)
criteria = Array("Name1", "Name2", "Name3")

pre = Format(Now, "dd-mm-yyyy")

Application.ScreenUpdating = False

For Each criterium In criteria
For iSht = LBound(sheetsToFilter) To UBound(sheetsToFilter)
Call Autofilter(ThisWorkbook.Worksheets(sheetsToFilter(iSht)).Range("A1"), CLng(sheetsColumnToFilterOn(iSht)), CStr(criterium))
Next iSht

Call CopySheet(sheetsToFilter, ThisWorkbook.Path & "\" & criterium & " " & pre & ".xlsx")
Next criterium

Application.ScreenUpdating = True

End Sub


Sub Autofilter(rng As Range, col As Long, criteria As String)

With rng
.Autofilter
.Autofilter field:=col, Criteria1:=criteria & "*", VisibleDropDown:=True
End With

End Sub


Sub CopySheet(sheetsToFilter As Variant, shtName As String)

ThisWorkbook.Worksheets(sheetsToFilter).Copy
ActiveWorkbook.SaveAs Filename:=shtName, FileFormat:=xlWorkbookDefault
ActiveWorkbook.Close False


End Sub


Thanks in advance!
 

Excel Facts

What is =ROMAN(40) in Excel?
The Roman numeral for 40 is XL. Bill "MrExcel" Jelen's 40th book was called MrExcel XL.

DanteAmor

Well-known Member
Joined
Dec 3, 2018
Messages
13,567
Office Version
  1. 2007
Platform
  1. Windows
Hi and welcome to MrExcel.

Try this

VBA Code:
Sub AutoFilters()
  Dim sheetsToFilter As Variant, sheetsColumnToFilterOn As Variant
  Dim criteria As Variant, criterium As Variant
  Dim iSht As Long
  Dim pre As String
  Dim wb1 As Workbook, wb2 As Workbook
  
  Application.ScreenUpdating = False
  Application.DisplayAlerts = False
  
  Set wb1 = ThisWorkbook
  sheetsToFilter = Array("Sheet2", "Sheet3", "Sheet4")
  sheetsColumnToFilterOn = Array(2, 3, 4)
  criteria = Array("Name1", "Name2", "Name3")
  pre = Format(Now, "dd-mm-yyyy")
  
  For Each criterium In criteria
    wb1.Sheets("Sheet1").Copy
    Set wb2 = ActiveWorkbook
    
    For iSht = LBound(sheetsToFilter) To UBound(sheetsToFilter)
      With wb1.Sheets(sheetsToFilter(iSht))
        .Range("A1").Autofilter field:=CLng(sheetsColumnToFilterOn(iSht)), Criteria1:=CStr(criterium) & "*"
        wb2.Sheets.Add After:=wb2.Sheets(wb2.Sheets.Count)
        wb2.Sheets(wb2.Sheets.Count).Name = sheetsToFilter(iSht)
        .Autofilter.Range.EntireRow.Copy
        wb2.Sheets(sheetsToFilter(iSht)).Range("A1").PasteSpecial xlPasteValues
        .ShowAllData
      End With
    Next iSht
    
    wb2.SaveAs wb1.Path & "\" & criterium & " " & pre & ".xlsx", xlWorkbookDefault
    wb2.Close False
  Next criterium
  Application.ScreenUpdating = True
End Sub
 

db2020

New Member
Joined
Jun 6, 2021
Messages
9
Office Version
  1. 365
  2. 2010
Platform
  1. Windows
Hey Dante,

Super, thanks a lot and much appreciated! It all works.

I do have some follow up questions:
1. The formatting of the first row of the pasted values should be the same as the original document. How do I add this?
2. Dates are now showing as numbers instead of a date (dd-mm-yyyy). How do I change this?
3. How do I autofit the columns so that all the data is completely visible (the columns now have a fixed width of 8.43 it seems)?
4. The front-page consists of 3 pivots. How do I automatically refresh them? The source of the pivot still refers to the original document.
 

db2020

New Member
Joined
Jun 6, 2021
Messages
9
Office Version
  1. 365
  2. 2010
Platform
  1. Windows
Hey Dante,

Super, thanks a lot and much appreciated! It all works.

I do have some follow up questions:
1. The formatting of the first row of the pasted values should be the same as the original document. How do I add this?
2. Dates are now showing as numbers instead of a date (dd-mm-yyyy). How do I change this?
3. How do I autofit the columns so that all the data is completely visible (the columns now have a fixed width of 8.43 it seems)?
4. The front-page consists of 3 pivots. How do I automatically refresh them? The source of the pivot still refers to the original document.
I managed to solve point 2&3
 

DanteAmor

Well-known Member
Joined
Dec 3, 2018
Messages
13,567
Office Version
  1. 2007
Platform
  1. Windows

ADVERTISEMENT

1. Format first row
2. Format dates
3. autofit the columns
4. Update pivot

I think it's all:

VBA Code:
Sub AutoFilters()
  Dim sheetsToFilter As Variant, sheetsColumnToFilterOn As Variant
  Dim criteria As Variant, criterium As Variant
  Dim iSht As Long
  Dim pre As String
  Dim wb1 As Workbook, wb2 As Workbook
  Dim pt As PivotTable
  Dim srcD As String, srcR As String, srcN As String
  
  Application.ScreenUpdating = False
  Application.DisplayAlerts = False
  
  Set wb1 = ThisWorkbook
  sheetsToFilter = Array("Sheet2", "Sheet3", "Sheet4")
  sheetsColumnToFilterOn = Array(2, 3, 4)
  criteria = Array("Name1", "Name2", "Name3")
  pre = Format(Now, "dd-mm-yyyy")
  
  For Each criterium In criteria
    wb1.Sheets("Sheet1").Copy
    Set wb2 = ActiveWorkbook
    'Change the source of the pivot tables
    For Each pt In wb2.Sheets(1).PivotTables
      srcD = pt.SourceData
      srcR = Mid(srcD, InStr(1, srcD, "!"))
      srcN = Replace(srcR, "F", "R")
      srcN = wb2.Sheets(1).Name & srcN
      pt.SourceData = srcN
      pt.PivotCache.Refresh
    Next
    
    For iSht = LBound(sheetsToFilter) To UBound(sheetsToFilter)
      With wb1.Sheets(sheetsToFilter(iSht))
        .Range("A1").Autofilter CLng(sheetsColumnToFilterOn(iSht)), CStr(criterium) & "*"
        wb2.Sheets.Add(After:=wb2.Sheets(wb2.Sheets.Count)).Name = sheetsToFilter(iSht)
        .Autofilter.Range.EntireRow.Copy
        wb2.Sheets(sheetsToFilter(iSht)).Range("A1").PasteSpecial xlPasteValues
        'Formatting of the first row
        .Rows(1).Copy wb2.Sheets(sheetsToFilter(iSht)).Rows(1)
        'autofit the columns
        wb2.Sheets(sheetsToFilter(iSht)).Cells.EntireColumn.AutoFit
        'format date (dd-mm-yyyy)
        wb2.Sheets(sheetsToFilter(iSht)).Columns("E:E").NumberFormat = "mm/dd/yyyy"
        .ShowAllData
      End With
    Next iSht
    
    wb2.SaveAs wb1.Path & "\" & criterium & " " & pre & ".xlsx", xlWorkbookDefault
    wb2.Close False
  Next criterium
  Application.ScreenUpdating = True
End Sub
 
Solution

db2020

New Member
Joined
Jun 6, 2021
Messages
9
Office Version
  1. 365
  2. 2010
Platform
  1. Windows
Thanks again Dante!

Unfortunately I get an error at the following line:
VBA Code:
 pt.SourceData = srcN

1623055748274.png
 

DanteAmor

Well-known Member
Joined
Dec 3, 2018
Messages
13,567
Office Version
  1. 2007
Platform
  1. Windows

ADVERTISEMENT

Run the macro from post #2.
Check the name of the pivot table in the new book.
Tell me what the pivot table is called and what appears in Data Source


1623117933069.png
 

db2020

New Member
Joined
Jun 6, 2021
Messages
9
Office Version
  1. 365
  2. 2010
Platform
  1. Windows
Hey Dante, apologies for the late reply. I have made some changes to the file in the meantime so that pivots are no longer necessary.

I do have another issue now. In column A of each tab I have a column with Data Validation (dropdown), and the Data Validation should also be pasted into the new file. How do I add this?
 

db2020

New Member
Joined
Jun 6, 2021
Messages
9
Office Version
  1. 365
  2. 2010
Platform
  1. Windows
Hey Dante, apologies for the late reply. I have made some changes to the file in the meantime so that pivots are no longer necessary.

I do have another issue now. In column A of each tab I have a column with Data Validation (dropdown), and the Data Validation should also be pasted into the new file. How do I add this?
.PasteSpecial xlPasteValidation
 

db2020

New Member
Joined
Jun 6, 2021
Messages
9
Office Version
  1. 365
  2. 2010
Platform
  1. Windows
Well after some struggling I managed to solve this one too :)
 

Forum statistics

Threads
1,140,999
Messages
5,703,639
Members
421,307
Latest member
morrden86

We've detected that you are using an adblocker.

We have a great community of people providing Excel help here, but the hosting costs are enormous. You can help keep this site running by allowing ads on MrExcel.com.
Allow Ads at MrExcel

Which adblocker are you using?

Disable AdBlock

Follow these easy steps to disable AdBlock

1)Click on the icon in the browser’s toolbar.
2)Click on the icon in the browser’s toolbar.
2)Click on the "Pause on this site" option.
Go back

Disable AdBlock Plus

Follow these easy steps to disable AdBlock Plus

1)Click on the icon in the browser’s toolbar.
2)Click on the toggle to disable it for "mrexcel.com".
Go back

Disable uBlock Origin

Follow these easy steps to disable uBlock Origin

1)Click on the icon in the browser’s toolbar.
2)Click on the "Power" button.
3)Click on the "Refresh" button.
Go back

Disable uBlock

Follow these easy steps to disable uBlock

1)Click on the icon in the browser’s toolbar.
2)Click on the "Power" button.
3)Click on the "Refresh" button.
Go back
Top