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

daviddiebel
daviddiebel used Ask the Experts™
on
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!
Comment
Watch Question

Do more with

Expert Office
EXPERT OFFICE® is a registered trademark of EXPERTS EXCHANGE®
hi David,

Ron Debruin has a ready made solution on his website which I have modified slightly.

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(1, "Profile", sh.Name) 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

Open in new window


hth
Rob

Author

Commented:
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
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

Do more with

Expert Office
Submit tech questions to Ask the Experts™ at any time to receive solutions, advice, and new ideas from leading industry professionals.

Start 7-Day Free Trial