Avatar of daviddiebel
daviddiebel
 asked on

How to save each worksheet with a name containing a specific character string as a new workbook?

This is a pretty specific question.  I use a workbook that contains a large number of worksheets.  Most of the worksheets are named "Profile1," "Profile2," and so on - all with names containing the word "profile"

If I make minor edits to one worksheet, all the "profile" worksheets update simultaneously. I need to regularly export each of the "profile" worksheets to new, separate workbook files - one worksheet for each new workbook.  So, each worksheet with a name containing the character string "profile" would need to be exported/saved as a workbook, while the other worksheets would not need to be exported.

And, preferably, each new workbook would be named according to the text contained in cell A1 of the worksheet being exported.

Thank you for your assistance!
Microsoft ExcelVisual Basic ClassicVB Script

Avatar of undefined
Last Comment
Rob Brockett

8/22/2022 - Mon
ASKER CERTIFIED SOLUTION
Rob Brockett

Log in or sign up to see answer
Become an EE member today7-DAY FREE TRIAL
Members can start a 7-Day Free trial then enjoy unlimited access to the platform
Sign up - Free for 7 days
or
Learn why we charge membership fees
We get it - no one likes a content blocker. Take one extra minute and find out why we block content.
Not exactly the question you had in mind?
Sign up for an EE membership and get your own personalized solution. With an EE membership, you can ask unlimited troubleshooting, research, or opinion questions.
ask a question
daviddiebel

ASKER
Thank you! I slightly modified it to get it to work...

Option Explicit

Sub Copy_Every_Sheet_To_New_Workbook()
'24/05/2012, RB: sourced & modified from http://www.rondebruin.nl/copy6.htm
'Working in 97-2010
Dim FileExtStr As String
Dim FileFormatNum As Long
Dim Sourcewb As Workbook
Dim Destwb As Workbook
Dim sh As Worksheet
Dim FolderName As String

    With Application
        .ScreenUpdating = False
        .EnableEvents = False
        .Calculation = xlCalculationManual
    End With

    'Copy every sheet from the workbook with this macro
    Set Sourcewb = ThisWorkbook

    FolderName = Sourcewb.Path & Application.PathSeparator

    'Copy every visible sheet to a new workbook
    For Each sh In Sourcewb.Worksheets

        'If the sheet contains "profile" in its name then copy it to a new workbook
        If InStr(sh.Name, "Profile") Then
            sh.Copy

            'Set Destwb to the new workbook
            Set Destwb = ActiveWorkbook

            'Determine the Excel version and file extension/format
            With Destwb
                If Val(Application.Version) < 12 Then
                    'You use Excel 97-2003
                    FileExtStr = ".xls": FileFormatNum = -4143
                Else
                    'You use Excel 2007-2010
                    If Sourcewb.Name = .Name Then
                        MsgBox "Your answer is NO in the security dialog"
                        GoTo GoToNextSheet
                    Else
                        Select Case Sourcewb.FileFormat
                            Case 51: FileExtStr = ".xlsx": FileFormatNum = 51
                            Case 52:
                                If .HasVBProject Then
                                    FileExtStr = ".xlsm": FileFormatNum = 52
                                Else
                                    FileExtStr = ".xlsx": FileFormatNum = 51
                                End If
                            Case 56: FileExtStr = ".xls": FileFormatNum = 56
                            Case Else: FileExtStr = ".xlsb": FileFormatNum = 50
                        End Select
                    End If
                End If
                'Save the new workbook and close it
                .SaveAs FolderName  _
                        & Destwb.Sheets(1).Range("a1").Value & FileExtStr, _
                        FileFormat:=FileFormatNum
                .Close False
            End With

        End If
GoToNextSheet:
    Next sh

    MsgBox "You can find the files in " & FolderName

    With Application
        .ScreenUpdating = True
        .EnableEvents = True
        .Calculation = xlCalculationAutomatic
    End With
    Set Sourcewb = Nothing
    Set Destwb = Nothing
End Sub
Rob Brockett

Ooopps, that's a bit of a shocker, I should have tested the code - esp as I often mess up the order of the arguments of the Instr function.

Oh well, I'm pleased I could point you in the right direction :-)

Rob
This is the best money I have ever spent. I cannot not tell you how many times these folks have saved my bacon. I learn so much from the contributors.
rwheeler23