Hello,
I have a workbook that has 9 tabs. I would like to have a VBA that automatically filters tab 2, for each of the names in column B. Then, it would save all the tabs in the workbook with the name that the list is filtered for on tab 2. All the workbooks would contain the same data, the the difference between each workbook would be the filtered list on tab 2.
Re: Create & Save filtered list into new workbook
Can't quite follow - it sounds like you want to save a copy of the workbook for each unique name in Sheet2/Col B but the only information in Sheet 2 is the name used for that workbook?
Upload a sample - it may help to see your data.
[sw]*[/sw]
Re: Create & Save filtered list into new workbook
Thank you for your reply. The idea is to filter column B by each value listed (total of 33 unique names) and saving the workbook as "Name M1", "Name M2", Etc. The new workbook would contain all the tabs as the original workbook but the list on tab 2 would be filtered.
Please let me know if this makes sense,
Thank you in advance.[ATTACH=CONFIG]70170[/ATTACH]
Re: Create & Save filtered list into new workbook
Quick and dirty...
Option Explicit
Private colNames As Collection
Sub Main()
Dim lngItem As Long
'// Stop screen flickering
Application.ScreenUpdating = False
'// Get unique list of names
MakeCollection
'// fopr each name...
For lngItem = 1 To colNames.Count
'// A little feedbar in the Excel Status bar (Bototm left of the Excel window)
Application.StatusBar = "Processing " & colNames(lngItem) & "..."
'// Copy entire workbook - creates a new workbook without code.
ThisWorkbook.Sheets.Copy
'// Remove N/A rows. Parameters are Active workbook (The new copy will be active by default),
'// and the name to keep (All others will be removed).
RemoveHiddenRows ActiveWorkbook.Sheets("2."), colNames(lngItem)
'// Save to the same directory as this workbook
With ActiveWorkbook
.SaveAs Filename:=ThisWorkbook.Path & "\" & colNames(lngItem), AddToMRU:=False, FileFormat:=xlWorkbookDefault
.Close
End With
Next
With Application
.ScreenUpdating = True
.StatusBar = False
End With
MsgBox "Finished...", vbInformation
End Sub
Private Sub RemoveHiddenRows(ws As Excel.Worksheet, strName As String)
Dim oRow As Range
Dim rng As Range
Dim myRows As Range
With ws
'// Make sure the worksheet contains data
Set myRows = Intersect(.Range("A:A").EntireRow, .UsedRange)
If myRows Is Nothing Then Exit Sub
'// Turn off filtering, just in case...
.AutoFilterMode = False
'// Note explicit references to range - Quick & Dirty to save time
With .Range("A11:I" & ws.Range("A" & Rows.Count).End(xlUp).Row)
.AutoFilter
'// Filter on Col 2 = passed name
.AutoFilter Field:=2, Criteria1:=strName, Operator:=xlFilterValues
End With
End With
'// Loop through ll cells in Col 2. If the row is not visible
'// then add to a range. The entire range is deleted later
For Each oRow In myRows.Columns(2).Cells
If oRow.EntireRow.Hidden Then
If rng Is Nothing Then
Set rng = oRow
Else
Set rng = Union(rng, oRow)
End If
End If
Next
If Not rng Is Nothing Then rng.EntireRow.Delete
'// And turn off autofiltering
ws.AutoFilterMode = False
End Sub
Private Sub MakeCollection()
Dim r As Excel.Range
Dim c As Excel.Range
Dim ws As Excel.Worksheet
Set colNames = New Collection
Set ws = ThisWorkbook.Sheets("2.")
On Error Resume Next
For Each c In ws.Range(ws.Range("B11"), ws.Range("B" & Rows.Count).End(xlUp))
colNames.Add c.Text, c.Text
Next
End SubAll the code goes in a module in the workbook to be copied. It could be speeded up a bit as it is mostly linear code without much optimisation but it seems to work.
Assumptions have been made - the workbooks will be saved in the same directory as the 'parent' workbook; you will get prompted if a file already exists when saving, it will not overwrite.
(The code formatting seems to have an error - that red line compiles OK in Excel)
Re: Create & Save filtered list into new workbook
cytop,
Thank you very much for the code and your time. I have a quick question about the new workbook that is saved. Is it possible to omit the step where the hidden rows on the new workbook are deleted? I would like to save the filtered list as is, instead of only moving the visible cells to a new workbook.
Re: Create & Save filtered list into new workbook
Misunderstood what you wanted to do with the hidden rows.
Simply comment out/delete the line calling the procedure RemoveHiddenRows. The procedure itself can also be removed
Re: Create & Save filtered list into new workbook
Cytop,
Removing the hidden rows procedures saves only saves a new workbook but the list is not filtered in this new workbook.
'RemoveHiddenRows ActiveWorkbook.Sheets("2."), colNames(lngItem)
do I need to rearrage the procedures?
Re: Create & Save filtered list into new workbook
My apologies - I changed the structure of the code and forgot.
Instead of commenting out the call to the procedure, just comment these lines (in RemoveHiddenRows):
'// Loop through all cells in Col 2. If the row is not visible
'// then add to a range. The entire range is deleted later
' For Each oRow In myRows.Columns(2).Cells
' If oRow.EntireRow.Hidden Then
' If rng Is Nothing Then
' Set rng = oRow
' Else
' Set rng = Union(rng, oRow)
' End If
' End If
' Next
' If Not rng Is Nothing Then rng.EntireRow.Delete
'
' '// And turn off autofiltering
' ws.AutoFilterMode = Falsealthough it should have been easy enough to follow as comments were included with each block of code that actually did sometihng.
Don’t have an account yet? Register yourself now and be a part of our community!