Copy an Array of Sheets with varying Sheet Names to a new Excel workbook

[EverClear]

Hi there!

(I am using Excel 2010) I have a workbook containing several worksheets. Many of the worksheets in the workbook have similar names: for example, "125005A," "125005B," "125005C," "120320A", "120320B," "130211A," "123456A," "123456B," "123456C," "123456D," and "123456E" are all in the *same* file. I want to create a macro that will prompt the user for the numeric portion of the spreadsheet name, and then copy all the spreadsheets containing that same numeric portion of the name as an *array* to a new workbook. In this example, my desired end result is:

125005A, 125005B, 125005C - Copied as an array of sheets into a new workbook
120320A, 120320B - Copied as an array of sheets into a SEPARATE new workbook
130211A - Copied into a SEPARATE new workbook
123456A, 123456B, 123456C, 123456D, and 123456E - Copied as an array of sheets into a SEPARATE new workbook

So in this example, the 1 original file containing 11 spreadsheets is parsed into 4 new workbooks. Here's the code I have so far:

Sub TestIt()
Dim arrShts()
Dim strWSName As String
Dim s As Worksheet
Dim I As Long
Set s = ActiveSheet
Do
On Error Resume Next
Application.DisplayAlerts = False
strWSName = Application.InputBox(Prompt:= _
"Please enter a dept id number ONLY. Do NOT include the 'DP'", _
Title:="Enter Dept ID", Type:=2)
On Error GoTo 0
Application.DisplayAlerts = True

If InStr(s.Name, strWSName) > 0 Then
ReDim Preserve arrShts(I)
arrShts(I) = s.Name
I = I + 1
End If

Sheets(arrShts).Copy '<--------- I get a "Type Mismatch" error at this step. Then the macro fails.

Loop Until MsgBox("Would you like copy another id?", vbYesNo) <> vbYes

 

[patel45]

1) s is activesheet, to scan all sheets you need a code like

for each sh in thisworkbook.sheets
  sname = sh.name
.........
next

2) you can copy only one sheet at a time, not an array of sheets

 

[Andrew Poulsom]

This worked for me:

Sub TestIt()
    Dim arrShts()
    Dim strWSName As String
    Dim s As Worksheet
    Dim I As Long
    Do
        On Error Resume Next
        Application.DisplayAlerts = False
        strWSName = Application.InputBox(Prompt:= _
            "Please enter a dept id number ONLY. Do NOT include the 'DP'", _
            Title:="Enter Dept ID", Type:=2)
        On Error GoTo 0
        Application.DisplayAlerts = True
        For Each s In ThisWorkbook.Worksheets
            If InStr(s.Name, strWSName) > 0 Then
                I = I + 1
                ReDim Preserve arrShts(1 To I)
                arrShts(I) = s.Name
            End If
        Next s
        Sheets(arrShts).Copy '<--------- I get a "Type Mismatch" error at this step. Then the macro fails.
    Loop Until MsgBox("Would you like copy another id?", vbYesNo) <> vbYes
End Sub

 

[Peter_SSs]

This is my attempt.
Whilst longer in written form,
- it does not require to loop through all the sheets each time.
- it does not produce a duplicate workbook if an invalid code like 33333 is entered after a valid code like 123456. My code produces a MessageBox at that point.
- it does not reproduce the whole workbook if a null code is entered by pressing OK with no code or if Cancel or the 'Close' button is clicked.

For mine, when you are finished choosing codes, at the InputBox press OK with no code or Cancel or the 'Close' button.

I wasn't sure if you wanted the books saved but I have saved them with the dept id number.
Anyway, give it a try

<font face=Courier New><br><SPAN style="color:#00007F">Sub</SPAN> Copy_Sheets()<br>  <SPAN style="color:#00007F">Dim</SPAN> strNames <SPAN style="color:#00007F">As</SPAN> <SPAN style="color:#00007F">String</SPAN>, strWSName <SPAN style="color:#00007F">As</SPAN> <SPAN style="color:#00007F">String</SPAN><br>  <SPAN style="color:#00007F">Dim</SPAN> arrNames, CopyNames<br>  <SPAN style="color:#00007F">Dim</SPAN> wbAct <SPAN style="color:#00007F">As</SPAN> Workbook<br>  <SPAN style="color:#00007F">Dim</SPAN> i <SPAN style="color:#00007F">As</SPAN> <SPAN style="color:#00007F">Long</SPAN><br>  <SPAN style="color:#00007F">Dim</SPAN> blnContinue <SPAN style="color:#00007F">As</SPAN> <SPAN style="color:#00007F">Boolean</SPAN><br>  <br>  <SPAN style="color:#00007F">Set</SPAN> wbAct = ActiveWorkbook<br>  blnContinue = <SPAN style="color:#00007F">True</SPAN><br>  <SPAN style="color:#00007F">For</SPAN> i = 1 <SPAN style="color:#00007F">To</SPAN> Sheets.Count<br>    strNames = strNames & "," & Sheets(i).Name<br>  <SPAN style="color:#00007F">Next</SPAN> i<br>  arrNames = Split(Mid(strNames, 2), ",")<br>  strWSName = "x"<br>  <SPAN style="color:#00007F">Do</SPAN> <SPAN style="color:#00007F">While</SPAN> blnContinue<br>    strWSName = Application.InputBox(Prompt:= _<br>      "Please enter a dept id number ONLY. Do NOT include the 'DP'", _<br>      Title:="Enter Dept ID", Type:=2)<br>    <SPAN style="color:#00007F">Select</SPAN> <SPAN style="color:#00007F">Case</SPAN> strWSName<br>      <SPAN style="color:#00007F">Case</SPAN> "", <SPAN style="color:#00007F">False</SPAN><br>        blnContinue = <SPAN style="color:#00007F">False</SPAN><br>      <SPAN style="color:#00007F">Case</SPAN> <SPAN style="color:#00007F">Else</SPAN><br>        Application.ScreenUpdating = <SPAN style="color:#00007F">False</SPAN><br>        CopyNames = Filter(arrNames, strWSName, <SPAN style="color:#00007F">True</SPAN>, vbTextCompare)<br>        <SPAN style="color:#00007F">If</SPAN> <SPAN style="color:#00007F">UBound</SPAN>(CopyNames) > -1 <SPAN style="color:#00007F">Then</SPAN><br>          Sheets(CopyNames).Copy<br>          ActiveWorkbook.SaveAs Filename:=strWSName<br>          wbAct.Activate<br>        <SPAN style="color:#00007F">Else</SPAN><br>          MsgBox "No sheets found: " & strWSName<br>        <SPAN style="color:#00007F">End</SPAN> <SPAN style="color:#00007F">If</SPAN><br>        Application.ScreenUpdating = <SPAN style="color:#00007F">True</SPAN><br>    <SPAN style="color:#00007F">End</SPAN> <SPAN style="color:#00007F">Select</SPAN><br>  <SPAN style="color:#00007F">Loop</SPAN><br><SPAN style="color:#00007F">End</SPAN> <SPAN style="color:#00007F">Sub</SPAN><br></FONT>

 

[patel45]

2) you can copy only one sheet at a time, not an array of sheets

Thanks Andrew, I learned something new, it's possible.

 

[Peter_SSs]

Just testing to see if another reply now will subscribe me to this thread.

Edit: Ah, yes, it is working again now.

 

[EverClear]

Hi Peter! It worked like a charm. Thanks to you, and to Everyone who replied. This site ROCKS!!!!

 

[Peter_SSs]

Hi Peter! It worked like a charm.

Glad it worked for you.

Just a couple of other comments about it:

1. The line strWSName = "x" can be deleted. In testing I was using that to help terminate my Loop but after changing to use blnContinue I forgot to remove that line.

2. I'm not sure if all your dept id numbers are 6 digits? Just note that if you only enter "12" in the InputBox, my code would copy any sheets that have 12 in their name (eg "125005B", "123456A", "881299C"). If that might be a problem for you, please provide more details as further checks could be put on the InputBox value and/or how the sheets are selected.