VBA to Move Named Sheets to New Workbook & Save

kabijenn

New Member
Joined
Jul 23, 2018
Messages
7
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

Well-known Member
Joined
Feb 26, 2006
Messages
1,089
If you want to saveas an .xls wotkbook

VBA Code:
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
 

Excel Facts

How to calculate loan payments in Excel?
Use the PMT function: =PMT(5%/12,60,-25000) is for a $25,000 loan, 5% annual interest, 60 month loan.

Watch MrExcel Video

Forum statistics

Threads
1,130,048
Messages
5,639,769
Members
417,111
Latest member
buyukbang

We've detected that you are using an adblocker.

We have a great community of people providing Excel help here, but the hosting costs are enormous. You can help keep this site running by allowing ads on MrExcel.com.
Allow Ads at MrExcel

Which adblocker are you using?

Disable AdBlock

Follow these easy steps to disable AdBlock

1)Click on the icon in the browser’s toolbar.
2)Click on the icon in the browser’s toolbar.
2)Click on the "Pause on this site" option.
Go back

Disable AdBlock Plus

Follow these easy steps to disable AdBlock Plus

1)Click on the icon in the browser’s toolbar.
2)Click on the toggle to disable it for "mrexcel.com".
Go back

Disable uBlock Origin

Follow these easy steps to disable uBlock Origin

1)Click on the icon in the browser’s toolbar.
2)Click on the "Power" button.
3)Click on the "Refresh" button.
Go back

Disable uBlock

Follow these easy steps to disable uBlock

1)Click on the icon in the browser’s toolbar.
2)Click on the "Power" button.
3)Click on the "Refresh" button.
Go back
Top