VBA - copy worksheet to another workbook if the sheet name matches partially

[aaltomar]

I have a source file (open workbook, not saved to a location) which can have 6 to xx number of sheets.

The source file sheet names usually follow the logic of:
Overview, Components, System-1, Hints-1, System-2, Hints-2, System-3, Hints-3,... Add-on products, Hints-12, Services etc...

I need to copy all the sheets from this source file where the names are as:

• System-1
• System-2
• System-...n
• + in adddition also "Add-on products" if it exists, there is only one if there are but there could be none

Up to possibly even 20 "System*" sheets but there could be as few as only one. So all the sheets where the sheetname starts with "System-*" need to be copied to another open workbook where the macro is activated from. The source file name can change, but it's usually Book1, Book2, Book6 etc, it depends. I'd say there's only one workbook open named Book(x) open at any given time so the source name usually starts the same.

The workbook to where I want to have the sheets copied to has already five existing sheets and the new sheets need to be copied after these.
The workbook where the sheets are to be copied to can be named in a certain fashion if it can't be generalized to a "template.xlsb" etc

The code that I've been testing really hasn't gotten me very far and I've spent some hours on this already googling the internet:

Sub copy_sheets()
    
    Dim ws As Worksheet

    Windows("Book2").Activate

    For Each ws In ActiveWorkbook.Sheets
        If InStr(1, ws.Name, "System*") Then
          
           ActiveWorkbook.Sheets("System*").Copy _
           After:=Workbooks("copyto").Sheets(5)
        
        End If
    Next
End Sub

 

[JackDanIce]

Welcome to the board. Change name in blue as required, then see if this helps progress:

Sub copy_sheets()
    
    Dim ws  As Worksheet
    Dim var As Variant
        
    Application.ScreenUpdating = False
    
    For Each ws In Workbooks("Book2").Sheets
        For Each var In Array("System*", "Add-on*")
            If InStr(ws.Name, cst(var)) Then ws.Copy After:=Workbooks("copyto").Sheets(Worksheets.Count)
        End If
    Next ws
    
    Application.ScreenUpdating = True
    
End Sub

 

[aaltomar]

Thanks for replying

I'm getting a "Compile error: Sub or Function not defined" and debug points to "cst" (constant?) in "If InStr(ws.Name, cst(var))"

Also can the source file reference also be wildcarded i.e. if there are no other workbooks open starting with "Book"?
For Each ws In Workbooks("Book*").Sheets

 

[JackDanIce]

Try:

Sub copy_sheets()
    
    Dim wkb As Workbook
    Dim ws  As Worksheet
    Dim var As Variant
        
    Application.ScreenUpdating = False
    
    For Each wkb In Workbooks
        For Each ws In wkb.Sheets
            For Each var In Array("System*", "Add-on*")
                If InStr(ws.Name, CStr(var)) Then ws.Copy After:=Workbooks("copyto").Sheets(Worksheets.Count)
            End If
        Next ws
    Next wkb
    
    Application.ScreenUpdating = True
    
End Sub

 

[aaltomar]

Now both versions give another Complile error (after fixing the typo on first cst to CStr): "End If without block if" and the "End if" gets painted.

On the second version I guess we are dropping the workbook references altogether and search through all? That shouldn't be a problem though.

 

[JackDanIce]

My fault, try:

Sub copy_sheets()
    
    Dim wkb As Workbook
    Dim ws  As Worksheet
    Dim var As Variant
        
    Application.ScreenUpdating = False
    
    For Each wkb In Workbooks
        For Each ws In wkb.Sheets
            For Each var In Array("System*", "Add-on*")
                If InStr(ws.Name, CStr(var)) Then ws.Copy After:=Workbooks("copyto").Sheets(Worksheets.Count)
            Next var
        Next ws
    Next wkb
    
    Application.ScreenUpdating = True
    
End Sub

 

[aaltomar]

Thanks for sticking with me, now a bit harder nut to crack, no errors but also no copied sheets. If I step though with F8 it loops between the array names and If InStr but never catches to "Then" and copy.
It seems the wildcard isn't catching the sheet names. If I substitute the array names with exact sheet names like "System-1" then it progresses to Then but with "Run-time error 9: Subscript out of range". Perhaps the macro doesn't now know where to copy the data?

The way I have it setup is that I have a dummy "analys" file for the macro and five sheets of placeholder data. I then created a new blank excel "Book4" and copied the data from my configurator export saved file and closed the original. So I have two files open, one is the data to be copied to template.xlsb and the source file which isn't saved. We usually discard the excel export after we've copied/transferred the data to my analysis file for further digestion. Having a macro to copy the configuration sheets to the analys file speeds up the process for uninitiated.

I had some success modyfying this code but I only managed to copy the 1st System-1 sheet multiple times. I also didn't quite know how to limit or extend the array.
Maybe "On Error Resume Next" would have helped when no System sheet were to be found anymore:

https://support.microsoft.com/en-us/kb/288402

<code>Sub Mover3() </code><code>   Dim BkName As String
   Dim NumSht As Integer
   Dim BegSht As Integer

   'Starts with second sheet - replace with index number of starting sheet.
   BegSht = 2
   'Moves two sheets - replace with number of sheets to move.
   NumSht = 2
   BkName = ActiveWorkbook.Name
    
    For x = 1 To NumSht
      'Moves second sheet in source to front of designated workbook.
      Workbooks(BkName).Sheets(BegSht).Move _
         Before:=Workbooks("Test.xls").Sheets(1)
         'In each loop, the next sheet in line becomes indexed as number 2.
      'Replace Test.xls with the full name of the target workbook you want.
    Next
End Sub</code>

 

[JackDanIce]

See if this altered name test works:

Sub copy_sheets()
    
    Dim wkb As Workbook
    Dim ws  As Worksheet
    Dim var As Variant
        
    Application.ScreenUpdating = False
    
    For Each wkb In Workbooks
        For Each ws In wkb.Sheets
            For Each var In Array("System*", "Add-on*")
                If ws.Name Like CStr(var) Then ws.Copy after:=Workbooks("copyto").Sheets(Worksheets.Count)
            Next var
        Next ws
    Next wkb
    
    Application.ScreenUpdating = True
    
End Sub

 

[aaltomar]

It now continues to copy but again the same subscript out of range and debug paints over "ws.Copy after:=Workbooks("copyto").Sheets(Worksheets.Count)" section.
And this is because "copyto" is the expected workbook. But if I substitute the "copyto" with the exact filename+extension where macro is ran from then it works!

I guess the last final bit would be to modify the code so that it would copy the sheets to the open workbook which contains contains the word "analys".
Then we could add additional sheets even after the file has been renamed based on customer (but would still retain the _analys_ in the filename).

As the sheets have some named ranges I also need to suppress the error messages and thus the working version:

Sub copy_sheets()
    
    Dim wkb As Workbook
    Dim ws  As Worksheet
    Dim var As Variant
    
    Application.DisplayAlerts = False
    Application.ScreenUpdating = False
    
    For Each wkb In Workbooks
        For Each ws In wkb.Sheets
            For Each var In Array("System*", "Add-on*")
                If ws.Name Like CStr(var) Then ws.Copy after:=Workbooks("analys_template.xlsb").Sheets(Worksheets.Count)
            Next var
        Next ws
    Next wkb
    
    Application.ScreenUpdating = True
    Application.DisplayAlerts = True
    
End Sub

So a lot of thanks and kudos to you Sir JackDanIce.

 

[JackDanIce]

You're welcome, good luck.