Macro to copy selected worksheets to new workbook

kellexlsx

New Member
Joined
Oct 9, 2017
Messages
20
Office Version
  1. 365
Platform
  1. Windows
Hi,

I've seen some similar posts, but most have been too specific for my needs. I have a workbook with 150+ worksheets, containing reports for 60+ employees. All have at least two worksheets; many have three or four. I need to be able to group the two, three, or four worksheets for each individual employee, and copy the group into a new workbook to save individualized reports. Any help would be appreciated!
 

Excel Facts

Waterfall charts in Excel?
Office 365 customers have access to Waterfall charts since late 2016. They were added to Excel 2019.
Hi & welcome to the board

How do we recognise which sheets belong to which employee?
 
Upvote 0
Thanks, Fluff. :)

Every sheet name begins with the employee's last name, or in case of multiple employees with the same last name, their last name with comma, a space, and the first letter of their first name. Then there are tags following the name, which may vary employee to employee.
 
Upvote 0
Could you create an extra sheet with the employees names like


Excel 2013 32 bit
A
1Banahan
2Burns
3Garvey
4Mercer, G
5Mercer, Z
Two
 
Last edited:
Upvote 0
OK try this
Code:
Sub CopySheets()

    Dim Ws As Worksheet
    Dim Ky As Variant
    Dim Cl As Range
    Dim Dict As Object
    Dim Cnt As Long
    Dim Arr() As Variant

Application.ScreenUpdating = False

    Set Dict = CreateObject("scripting.dictionary")
    With Dict
        For Each Cl In Sheets("[COLOR=#0000ff]Names[/COLOR]").Range("A1", Sheets("[COLOR=#0000ff]Names[/COLOR]").Range("A" & Rows.Count).End(xlUp))
            If Not .exists(Cl.Value) Then .Add Cl.Value, Nothing
        Next Cl
    End With
    
    For Each Ky In Dict.keys
        For Each Ws In Worksheets
            If Ws.Name Like Ky & "*" Then
                Cnt = Cnt + 1
                ReDim Preserve Arr(1 To Cnt)
                Arr(Cnt) = Ws.Name
            End If
        Next Ws
        Sheets(Arr).Copy
        ActiveWorkbook.SaveAS "[COLOR=#ff0000]C:\Users\Fluff\Desktop\test\[/COLOR]" & Ky, 51
        ActiveWorkbook.Close
        Erase Arr()
        Cnt = 0
    Next Ky

End Sub
This will copy the relevant sheets to a new workbook & save that file
The value in blue is the name of the sheet, where the employee names are (change if needed) & the names start in A1
The part in red is where the files will be saved, once again change as needed.
 
Upvote 0
That was AMAZING. :eek:

It did save all the new workbooks with the word "Desktop" before the employee name, did I fail to edit something properly?
 
Upvote 0
Sound like your missing a \ from the end of the path name.
 
Upvote 0
I was, indeed. Thank you, thank you - you've saved me a lot of time. Much appreciated!
 
Upvote 0
Glad to help & thanks for the feedback
 
Upvote 0

Forum statistics

Threads
1,213,536
Messages
6,114,213
Members
448,554
Latest member
Gleisner2

We've detected that you are using an adblocker.

We have a great community of people providing Excel help here, but the hosting costs are enormous. You can help keep this site running by allowing ads on MrExcel.com.
Allow Ads at MrExcel

Which adblocker are you using?

Disable AdBlock

Follow these easy steps to disable AdBlock

1)Click on the icon in the browser’s toolbar.
2)Click on the icon in the browser’s toolbar.
2)Click on the "Pause on this site" option.
Go back

Disable AdBlock Plus

Follow these easy steps to disable AdBlock Plus

1)Click on the icon in the browser’s toolbar.
2)Click on the toggle to disable it for "mrexcel.com".
Go back

Disable uBlock Origin

Follow these easy steps to disable uBlock Origin

1)Click on the icon in the browser’s toolbar.
2)Click on the "Power" button.
3)Click on the "Refresh" button.
Go back

Disable uBlock

Follow these easy steps to disable uBlock

1)Click on the icon in the browser’s toolbar.
2)Click on the "Power" button.
3)Click on the "Refresh" button.
Go back
Back
Top