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

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