Ищем решение VBA: как выборочно копировать и сохранять рабочие листы на основе заголовков рабочих листов

Концептуально:

• используйте цикл For-Next, который проходит через все листы в книге
• сравните каждое имя листа со списком ключевых слов
• когда имя листа удовлетворяет условию, выполните копирование

На этом и других сайтах есть множество примеров кода о том, как перебирать все листы в книге, как найти строку в другой строке и как копировать листы между книгами.

Экспортировать указанные листы в новую книгу

Sub ExportSheetsByActivityCodes()
    Const PROC_TITLE As String = "Export Sheets By Activity Codes"
    Dim dwb As Workbook ' to be closed if error
    Dim WasSuccess As Boolean
    On Error GoTo ClearError ' start error-handling routine
    
    ' Define constants.
    
    Const DST_FILE_BASE_NAME As String = "New File"
    ' The following two constants have to be in 'sync'.
    Const DST_FILE_EXTENSION As String = ".xlsm"
    Const DST_FILE_FORMAT As Long = xlOpenXMLWorkbookMacroEnabled
    Const DST_FILE_FILTER_LEFT As String = "Excel macro-enabled files"
    Const ORDER_BY_WORKSHEET_POSITION As Boolean = False
    
    Dim ActivityCodes() As Variant: ActivityCodes = VBA.Array( _
        "BBA", "BBV", "BBB") ' add more
     
    ' Ask to proceed.
     
    ' Return the values of the array in a delimited string (for the messages).
    Dim ActivityCodesList As String:
    ActivityCodesList = Join(ActivityCodes, ", ")
     
    If MsgBox("Do you want to copy the worksheets named after activity " _
        & "codes """ & ActivityCodesList & """ to a new workbook?" _
        & vbLf & "The worksheets in the new workbook will be without " _
        & "formulas and hyperlinks, and named ranges will be removed!", _
        vbYesNo + vbQuestion, PROC_TITLE) = vbNo Then GoTo ProcExit
     
    ' Return the names of the worksheets to be exported in a 1D one-based array.
    
    Dim swb As Workbook: Set swb = ThisWorkbook ' workbook containing this code
     
    ' Define an array of the size of the number of activity codes.
    Dim dwsMax As Long: dwsMax = UBound(ActivityCodes) + 1
    Dim dwsNames() As Variant: ReDim dwsNames(1 To dwsMax)
     
    Dim sws As Worksheet, dwsCount As Long, n As Long
    
    If ORDER_BY_WORKSHEET_POSITION Then
        For Each sws In swb.Worksheets
            If IsNumeric(Application.Match(sws.Name, ActivityCodes, 0)) Then
                dwsCount = dwsCount + 1
                dwsNames(dwsCount) = sws.Name
            End If
            If dwsCount = dwsMax Then Exit For ' all found
        Next sws
    Else ' order by activity code
        For n = 1 To dwsMax
            On Error Resume Next ' defer error handling (sheet doesn't exist)
                Set sws = swb.Worksheets(ActivityCodes(n - 1))
            On Error GoTo ClearError ' restart error-handling routine
            If Not sws Is Nothing Then
                dwsCount = dwsCount + 1
                dwsNames(dwsCount) = sws.Name
                Set sws = Nothing ' reset for the next iteration
            End If
        Next n
    End If
    
    If dwsCount = 0 Then
        MsgBox "No worksheets named after activities """ & ActivityCodesList _
            & """ found!", vbExclamation, PROC_TITLE
        GoTo ProcExit
    End If
    
    If dwsCount < dwsMax Then ReDim Preserve dwsNames(1 To dwsCount)
    
    ' Copy the worksheets whose names are in the array to a new workbook
    ' and reference this workbook.
    ' Note that when copying multiple sheets to a new workbook,
    ' the order of the sheets is always the same as their order
    ' in the source workbook (no matter their order in the array).
    ' Note that this will fail if there is no visible worksheet,
    ' and very hidden worksheets will not be copied.
    swb.Sheets(dwsNames).Copy
    Set dwb = Workbooks(Workbooks.Count)
    
    ' Process the destination workbook.
    
    Dim dws As Worksheet, nm As Name
    
    ' Process worksheets.
    For Each dws In dwb.Worksheets
        With dws.UsedRange
            .Hyperlinks.Delete ' delete hyperlinks
            .Value = .Value ' formulas to values
            Application.Goto Reference:=.Cells(1), Scroll:=True
        End With
    Next dws
    
    ' Process workbook.
    For Each nm In dwb.Names
        If nm.Visible Then nm.Delete '???
    Next nm
    
    ' Move sheets to correct positions when ordering by activity code required.
    If Not ORDER_BY_WORKSHEET_POSITION And dwsCount > 1 Then
        For n = 1 To dwsCount
            dwb.Sheets(dwsNames(n)).Move After:=dwb.Sheets(dwsCount)
        Next n
    End If
    
    ' Let the user choose the location and name of the destination file.
    
    Dim dFileFilter As String:
    dFileFilter = DST_FILE_FILTER_LEFT & ",*" & DST_FILE_EXTENSION
    
    Dim dFilePath As Variant: dFilePath = Application.GetSaveAsFilename( _
        InitialFileName:=swb.Path & Application.PathSeparator & _
            DST_FILE_BASE_NAME, _
        FileFilter:=dFileFilter, _
        Title:=PROC_TITLE)
    
    If dFilePath = False Then
        MsgBox "File save canceled.", vbExclamation, PROC_TITLE
        GoTo ProcExit
    End If
    
    ' Prevent error if file (or file with same name) is open
    ' Note that the error-handling routine could cover this instead!
    ' Note that you cannot change the given file extension.
    
    Dim dFileName As String: dFileName = Right(dFilePath, _
        Len(dFilePath) - InStrRev(dFilePath, Application.PathSeparator))
    
    Dim cwb As Workbook
    
    On Error Resume Next ' defer error handling (file (workbook) exists)
        Set cwb = Workbooks(dFileName)
    On Error GoTo ClearError ' restart error-handling routine
    
    If Not cwb Is Nothing Then
        If StrComp(dFilePath, cwb.FullName, vbTextCompare) = 0 Then
            MsgBox "The destination file """ & cwb.FullName & """ is open!", _
                vbExclamation, PROC_TITLE
        Else
            MsgBox "Another file """ & cwb.FullName _
                & """ with the same name is open!", vbExclamation, PROC_TITLE
        End If
        GoTo ProcExit
    End If
        
    ' Save and close.
        
    Application.DisplayAlerts = False ' overwrite without confirmation
        dwb.SaveAs Filename:=dFilePath, FileFormat:=DST_FILE_FORMAT
    Application.DisplayAlerts = False
    dwb.Close SaveChanges:=False ' just got saved
                
    Application.ScreenUpdating = True
    
    WasSuccess = True
    
    ' Inform.
    
    MsgBox "The following " & IIf(dwsCount <> 1, dwsCount & " ", "") _
        & "sheet" & IIf(dwsCount = 1, " was", "s were") & " exported to """ _
        & dFilePath & """:" & vbLf & vbLf & Join(dwsNames, vbLf), _
        vbInformation, PROC_TITLE
    
ProcExit:
    On Error Resume Next ' prevent endless loop if error in continuation
        If Not WasSuccess Then
            If Not dwb Is Nothing Then dwb.Close SaveChanges:=False
        End If
    On Error GoTo 0
    Exit Sub
ClearError: ' continue error-handling routine (e.g. invalid file name)
    MsgBox "Run-time error '" & Err.Number & "':" & vbLf & vbLf _
        & Err.Description, vbCritical, PROC_TITLE
    Resume ProcExit
End Sub