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

[db2020]

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)?

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!

 

[DanteAmor]

Hi and welcome to MrExcel.

Try this

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]

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]

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]

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

I think it's all:

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

 

[db2020]

Thanks again Dante!

Unfortunately I get an error at the following line:

 pt.SourceData = srcN

 

[DanteAmor]

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

 

[db2020]

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]

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]

Well after some struggling I managed to solve this one too