VBA to Move Named Sheets to New Workbook & Save

[kabijenn]

Hello Experts! I have a massive Excel file that I need to take specific worksheets (that have tables) to a new workbook, save as the tab name. I want to be able to specify which worksheets (that may, or may not be visible) that I want to have the code move/save. I have found two examples of code (pasted below) and I was trying to merge them and it just wasn't working. Can anyone PLEASE help?!! Thank you!!!

This code unhides the worksheets given a specific name:
'Set tab naming convention to hide & unhide
Const TABNAME As String = "1218"

Sub Unhide_Named_Sheets()
'Unhide all sheets that end with -h
Dim ws As Object 'Use object instead of worksheet for Chartsheets
'Unhide sheets with sheet name ending in -h
For Each ws In ActiveWorkbook.Sheets
If Right(ws.Name, 4) = TABNAME Then
ws.Visible = xlSheetVisible
End If
Next ws
End Sub

This code creates a folder & moves all worksheets (which is the problem, I want only those that I specify, so for example, only those worksheets that end in 1218) to a new workbook, saves the workbook as the tab name.

Option Explicit

Sub SaveShtsAsBook()
Dim Sheet As Worksheet, SheetName$, MyFilePath$, N&
MyFilePath$ = ActiveWorkbook.Path & "\" & _
Left(ThisWorkbook.Name, Len(ThisWorkbook.Name) - 4)
With Application
.ScreenUpdating = False
.DisplayAlerts = False
' End With
On Error Resume Next '<< a folder exists
MkDir MyFilePath '<< create a folder
For N = 1 To Sheets.Count
Sheets(N).Activate
SheetName = ActiveSheet.Name
Cells.Copy
Workbooks.Add (xlWBATWorksheet)
With ActiveWorkbook
With .ActiveSheet
.Paste
.Name = SheetName
[A1].Select
End With
'save book in this folder
.SaveAs Filename:=MyFilePath _
& "\" & SheetName & ".xls"
.Close SaveChanges:=True
End With
.CutCopyMode = False
Next
End With
Sheet1.Activate
End Sub

 

[davesexcel]

Could you have a saveas macro for the original sheet as the tabname, then delete the worksheets you don't want?

 

[kabijenn]

Hi Dave - I'm not sure I understand your question. If the macro moves & saves the worksheets, I won't need to delete the originals. Or are you suggesting a macro that takes the named worksheets and copies instead of moves and then I delete the original? If that's the case, absolutely. My biggest time saver that I need is having a macro that either copies or moves the worksheets based off of the last 4 digits of the tabname & saves using the tabname. I can delete the originals no problem. Thanks!!

 

[davesexcel]

I'm saying ,use a macro to just rename the workbook and delete the worksheets you don't want

 

[kabijenn]

Oh no, I can't do that, each individual sheet represents a customers data for a given month and then I have a "master sheet" that has all sorts of formulas to convert each tab of the customers data to a specific format so that the master sheet can used to feed a SQL table (which I need to keep some in the workbook as the data can change in a given quarter). The workbook itself has gotten so massive that it locks up on me. So I have been hardcoding the older rows and then moving the corresponding tabs to new workbooks so that I can save what the customer's data was for that given month, but also make my workbook smaller and easier to work with. I inherited this so I'm slowly trying to make improvements on it. Right now I am trying to move/save the 2016-2018 tabs & the first half of 2019 tabs just so I can work in the workbook. Next year I will revamp the entire process so that the individual tabs will just go directly into SQL and I won't need this "master sheet" at all. I'm just not there yet.

 

[davesexcel]

Okay,
You can make an array of sheets and turn them into a new workbook.
Test it out.

Sub MakeArraySheets()
    Dim sh As Worksheet
    Dim ArraySheets() As String
    Dim x As Variant

    For Each sh In ActiveWorkbook.Worksheets
        If InStr(sh.Name, 2018) <> 0 Then
            ReDim Preserve ArraySheets(x)
            ArraySheets(x) = sh.Name
            x = x + 1
        End If
    Next sh

    Sheets(ArraySheets).Copy    'change to move if you want to move the sheets

    MsgBox "Your saveas code goes here"

End Sub

 

[dmt32]

Hi,
you could add a parameter to your code & pass the sheet names you want to copy

See if this update to your code do es what you want

Sub SaveShtsAsBook(ParamArray SheetNames() As Variant)
        Dim SheetName As String, MyFilePath As String
        Dim CopySheets As Variant
        Dim wb As Workbook
        Dim ws As Worksheet
        
        CopySheets = SheetNames
        
        MyFilePath = ActiveWorkbook.Path & "\" & _
                      Left(ThisWorkbook.Name, Len(ThisWorkbook.Name) - 4)
'<< a folder exists
        On Error Resume Next
'<< create a folder
        MkDir MyFilePath
        On Error GoTo 0
        
        Application.ScreenUpdating = False
        For Each ws In ThisWorkbook.Worksheets
            If Not IsError(Application.Match(ws.Name, CopySheets, 0)) Then
            SheetName = ws.Name
            ws.UsedRange.Copy
            Set wb = Workbooks.Add(xlWBATWorksheet)
            With wb
                With .Sheets(1)
                    .Paste
                    .Name = SheetName
                End With
'save book in this folder
                .SaveAs Filename:=MyFilePath & "\" & SheetName & ".xls", FileFormat:=56
                .Close False
            End With
            End If
            Application.CutCopyMode = False
            Set wb = Nothing
        Next
     Sheet1.Activate
    Application.ScreenUpdating = True
End Sub

to call, just list all sheet names you want to be copied.

SaveShtsAsBook "Sheet2", "Sheet4", "Sheet6"

Dave

 

[kabijenn]

Hi,
you could add a parameter to your code & pass the sheet names you want to copy

See if this update to your code do es what you want

Sub SaveShtsAsBook(ParamArray SheetNames() As Variant)
        Dim SheetName As String, MyFilePath As String
        Dim CopySheets As Variant
        Dim wb As Workbook
        Dim ws As Worksheet
       
        CopySheets = SheetNames
       
        MyFilePath = ActiveWorkbook.Path & "\" & _
                      Left(ThisWorkbook.Name, Len(ThisWorkbook.Name) - 4)
'<< a folder exists
        On Error Resume Next
'<< create a folder
        MkDir MyFilePath
        On Error GoTo 0
       
        Application.ScreenUpdating = False
        For Each ws In ThisWorkbook.Worksheets
            If Not IsError(Application.Match(ws.Name, CopySheets, 0)) Then
            SheetName = ws.Name
            ws.UsedRange.Copy
            Set wb = Workbooks.Add(xlWBATWorksheet)
            With wb
                With .Sheets(1)
                    .Paste
                    .Name = SheetName
                End With
'save book in this folder
                .SaveAs Filename:=MyFilePath & "\" & SheetName & ".xls", FileFormat:=56
                .Close False
            End With
            End If
            Application.CutCopyMode = False
            Set wb = Nothing
        Next
     Sheet1.Activate
    Application.ScreenUpdating = True
End Sub

to call, just list all sheet names you want to be copied.

SaveShtsAsBook "Sheet2", "Sheet4", "Sheet6"

Dave

Thanks Dave! I can't get this to work (admittedly I am new to VBA so please excuse my ignorance)...but from what I can gather from reading this, I would have to specifically name each sheet that I want to move/save. Every customer in this workbook would have a sheet for each month, for example, "Customer A_1218", so I want to say all sheets ending in "1218" would be moved and each saved in their own workbook.

 

[davesexcel]

FYI, there are two Daves on this thread
Actually, it just looks for 2018 in the sheet name and places it in the sheet array, but you could change the parameters to,

If right(sh.Name,4) = 2018 Then

 

[kabijenn]

You are right, my apologies on the multiple Dave's. I just tried what you sent, updating it to Move and it worked perfectly. However, I do not know how to add the piece where it automatically saves the new workbook as the tabname? Location is irrelevant, can be the same location as the 'master workbook'. Can you help me add that piece? Again, thank you for your patience and assistance!!