Split a worksheet into multiple workbooks based on a table

I have code in module1 and code on the sheet "Sheet1".  The code in module1 will have the user select the current months spreadsheet and then copy of the data into this spreadsheet.  After it has been copied I am attempting to split the sheet into multiple workbooks based on the table in sheet "Names".  The code attached to sheet "Sheet1" works up to the point where I added the code to update the format of the new spreadsheet.  I would like for the user to only have to select 1 macro and then the file name, but I am not sure how to do it.  Thanks in advance for any assistance.

Thanks,
Joan
PQRS-Macro.xlsm
jmkbrownAsked:
Who is Participating?

[Product update] Infrastructure Analysis Tool is now available with Business Accounts.Learn More

x
I wear a lot of hats...

"The solutions and answers provided on Experts Exchange have been extremely helpful to me over the last few years. I wear a lot of hats - Developer, Database Administrator, Help Desk, etc., so I know a lot of things but not a lot about one thing. Experts Exchange gives me answers from people who do know a lot about one thing, in a easy to use platform." -Todd S.

jmkbrownAuthor Commented:
I have found a solution to my problem.  Attached is the code I am using to split the spreadsheet into multiple spreadsheets.

Sub SplitData()
    Dim strPath As String
    Dim intChoice As Integer
    Dim FilterCriteria
    Dim CurrentSheetName As String
    Dim NewFileName As String
    Dim wb As Workbook
    Dim intCount As Integer
    Dim i As Integer
    Dim YearMonth As String
    
    Application.ScreenUpdating = False
    
    '****  Select the new PQRS spreadsheet!!!
    'Remove all other filters
    Call Application.FileDialog(msoFileDialogOpen).Filters.Clear
    'Add a custom filter
    Call Application.FileDialog(msoFileDialogOpen).Filters.Add( _
        "Excel Files Only", "*.xls*")
    'make the file dialog visible to the user
    intChoice = Application.FileDialog(msoFileDialogOpen).Show
    'determine what choice the user made
    If intChoice = 0 Then
        MsgBox "No file was selected", vbInformation + vbOKOnly, "No File"
        Exit Sub
    End If
    strPath = Application.FileDialog( _
        msoFileDialogOpen).SelectedItems(1)
    Workbooks.Open Filename:=strPath
    Set wb = ActiveWorkbook
    
    ' Move contents of current PQRS to This workbook
    
    ThisWorkbook.Activate
    Sheets("Sheet1").Select
    Range("A2").Select
    Range(Selection, Selection.End(xlDown)).Select
    Range(Selection, Selection.End(xlToRight)).Select
    Selection.ClearContents
    Range("A2").Select
    wb.Activate
    Range("A2").Select
    Range(Selection, Selection.End(xlDown)).Select
    Range(Selection, Selection.End(xlToRight)).Select
    Selection.Copy
    ThisWorkbook.Activate
    Selection.PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks _
        :=False, Transpose:=False
    Application.CutCopyMode = False
    
    wb.Close
    
    'Get the Current sheets's name
    Sheets("Sheet1").Select
    CurrentSheetName = ActiveSheet.Name
    
    'Determine number of providers
    Sheets("Names").Select
    intCount = Range("F2").Value
    YearMonth = Range("I2").Value
    
    For i = 1 To intCount
        'select the range
        Sheets("Sheet1").Select
        Range("A1:H3000").Select
        
        'Apply AutoFilter
        Selection.AutoFilter
        
        'Get the filter's criteria
        Sheets("Names").Select
        FilterCriteria = Trim(Range("A" & i + 1).Value)
        
        'Filter the data
        Sheets("Sheet1").Select
        Selection.AutoFilter field:=1, Criteria1:=FilterCriteria
        
        'Select the visible cells (the filtered data)
        Selection.SpecialCells(xlCellTypeVisible).Select
        
        'Copy the cells
        Selection.Copy
        Workbooks.Add
        Set wb = ActiveWorkbook
        Range("A1").Select
        ActiveSheet.Paste
        Application.CutCopyMode = False
        
        ThisWorkbook.Activate
        Range("A1").Select
        Range(Selection, Selection.End(xlToRight)).Select
        Selection.Copy
        wb.Activate
        Selection.PasteSpecial Paste:=xlPasteColumnWidths, Operation:=xlNone, _
            SkipBlanks:=False, Transpose:=False
        ActiveCell.Offset(1, 0).Select
        Range(Selection, Selection.End(xlDown)).Select
        Range(Selection, Selection.End(xlToRight)).Select
        Selection.PasteSpecial Paste:=xlPasteFormats, Operation:=xlNone, _
            SkipBlanks:=False, Transpose:=False
        Selection.Font.Bold = False
        wb.Activate
        With ActiveSheet.PageSetup
            .Orientation = xlLandscape
            .LeftMargin = Application.InchesToPoints(0)
            .RightMargin = Application.InchesToPoints(0)
            .TopMargin = Application.InchesToPoints(0)
            .BottomMargin = Application.InchesToPoints(0)
        End With
        wb.SaveAs ThisWorkbook.Path & "\Provider_" & FilterCriteria & _
            "_" & YearMonth
        wb.Close
        
        'Go back to the original sheet
        Worksheets(CurrentSheetName).Activate
        
        'Clear the autofilter
        Selection.AutoFilter field:=1
        Selection.AutoFilter
        
        'Go to A1
        Range("A1").Select
        
    Next i
End Sub

Open in new window

Experts Exchange Solution brought to you by

Your issues matter to us.

Facing a tech roadblock? Get the help and guidance you need from experienced professionals who care. Ask your question anytime, anywhere, with no hassle.

Start your 7-day free trial
It's more than this solution.Get answers and train to solve all your tech problems - anytime, anywhere.Try it for free Edge Out The Competitionfor your dream job with proven skills and certifications.Get started today Stand Outas the employee with proven skills.Start learning today for free Move Your Career Forwardwith certification training in the latest technologies.Start your trial today
Spreadsheets

From novice to tech pro — start learning today.