Macro to copy selected worksheets to new workbook

[kellexlsx]

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!

 

[Fluff]

Hi & welcome to the board

How do we recognise which sheets belong to which employee?

 

[kellexlsx]

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.

 

[Fluff]

Could you create an extra sheet with the employees names like

Excel 2013 32 bit
	A
1	Banahan
2	Burns
3	Garvey
4	Mercer, G
5	Mercer, Z
Two

 

[kellexlsx]

Easily.

 

[Fluff]

OK try this

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.

 

[kellexlsx]

That was AMAZING.

It did save all the new workbooks with the word "Desktop" before the employee name, did I fail to edit something properly?

 

[Fluff]

Sound like your missing a \ from the end of the path name.

 

[kellexlsx]

I was, indeed. Thank you, thank you - you've saved me a lot of time. Much appreciated!

 

[Fluff]

Glad to help & thanks for the feedback