Looking for a VBA solution: How to Selectively Copy and Save Worksheets based on Worksheet Titles

Question

My organization publishes a weekly report in Excel format containing over 60 worksheets, each titled with an activity abbreviation. I am interested in specific worksheets only. Currently, I manually search and copy these worksheets into a new workbook. Existing VBA solutions appear to require predefined worksheet names in an array, which will not work in my case because when there is no activity, a corresponding worksheet titled with the activity code is not included in the workbook.

I am seeking VBA code that can:

• Identify worksheets based on specific activity codes in their names ( I have a complete list)
• Skip names when the worksheets are not in the workbook
• Copy and save the identified worksheets into a new workbook

Ideally, the end user would be able to choose the destination for saving the new workbook, rather than it being automatically saved in the original workbook's path.

Thank you very much!

I am new to VBA so I tried to modify a code by merging multiple codes I found online but was unsuccessful. For the test I only used three worksheet names (A real run would pull 20). The worksheets titled ""BBA" & "BBB" are in the workbook while "BBV" is not. I am certainly open to going a different direction with this as I am certain there is a cleaner way to write this.

Sub TwoSheetsAndYourOut()
    Dim NewName As String
    Dim nm As Name
    Dim ws As Worksheet
    Dim MyArr, j As Long
     
    If MsgBox("Copy specific sheets to a new workbook" & vbCr & _
    "New sheets will be pasted as values, named ranges removed" _
    , vbYesNo, "NewCopy") = vbNo Then Exit Sub
     
    Application.ScreenUpdating = False
         
         '       Copy specific sheets
         '       *SET THE SHEET NAMES TO COPY BELOW*
         '       Array("Sheet Name", "Another sheet name", "And Another"))
         '       Sheet names go inside quotes, seperated by commas
        On Error GoTo ErrCatcher
        MyArr = Array("BBA", "BBV", "BBB")

        For j = 0 To UBound(MyArr)
            Set ws = Nothing

        On Error Resume Next
        Set ws = Worksheets(MyArr(j))
        On Error GoTo 0

        If Not ws Is Nothing Then
        'Your copying code goes here

         '       Paste sheets as values
         '       Remove External Links, Hperlinks and hard-code formulas
         '       Make sure A1 is selected on all sheets
        ws.Select
            ws.Cells.Copy
            ws.[A1].PasteSpecial Paste:=xlValues
            ws.Cells.Hyperlinks.Delete
            Application.CutCopyMode = False
            Cells(1, 1).Select
            ws.Activate
        End If
    Next
         '       Remove named ranges
        For Each nm In ActiveWorkbook.Names
        If nm.Visible Then nm.Delete
        Next nm
         
         '       Input box to name new file
        NewName = InputBox("Please Specify the name of your new workbook", "New Copy")
         
         '       Save it with the NewName and in the same directory as original
        ActiveWorkbook.SaveAs Filename:=ThisWorkbook.Path & Application.PathSeparator & "myFile.xlsm", FileFormat:=52
                
        Application.ScreenUpdating = True
    Exit Sub
     
ErrCatcher:
    MsgBox "Specified sheets do not exist within this workbook"
End Sub

Answer 1

Export Specified Worksheets to New Workbook

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

Answer 2

Conceptually:

• use a For-Next loop that goes through all worksheets in the workbook
• compare each worksheet name against your keyword list
• when a worksheet name satisfies the condition, perform the copy

There are many code examples on this site and others on how to loop through all sheets in a workbook, how to find a string in another string, and how to copy worksheets between workbooks.