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]

If you want to saveas an .xls wotkbook

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

    MyDir = ThisWorkbook.Path & "\"
    TabName = 2018
    For Each sh In ActiveWorkbook.Worksheets
        If InStr(sh.Name, TabName) <> 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

    With ActiveWorkbook
        .SaveAs MyDir & TabName & ".xls", FileFormat:=56     'xlExcel8 (97-2003 format xls)
        .Close
    End With
End Sub

 

[kabijenn]

Thank you so much!!!!!