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