divide and save worksheets as separate files

Question

I have several the same worksheets named "Copy Transposed" (Copy Transposed, Copy Transposed(2),Copy Transposed(3) etc.) I'd like to write a macro that will copy one Copy Transposed* worksheet with "Test1", "Test2", "Test3", "Test4", "Test5". So if I have 5 copy transposed worksheets I want to have 5 seperate files with copy transposed and "Test1", "Test2", "Test3", "Test4", "Test5". The name of the file should be the same as the name of the active worksheet. For instance I have 5 copy transposed worksheets so:

File 1- Copy Transposed.xlsm contains of "Copy Transposed", "Test1", "Test2", "Test3", "Test4", "Test5".
File 2- Copy Transposed(2).xlsm contains of "Copy Transposed(2)", "Test1", "Test2", "Test3", "Test4", "Test5".
File 3- Copy Transposed(3).xlsm contains of "Copy Transposed(3)", "Test1", "Test2", "Test3", "Test4", "Test5".
File 4- Copy Transposed(4).xlsm contains of "Copy Transposed(4)", "Test1", "Test2", "Test3", "Test4", "Test5".
File 5- Copy Transposed(5).xlsm contains of "Copy Transposed(5)", "Test1", "Test2", "Test3", "Test4", "Test5".

The number of "Copy Transposed" worksheets is always different

Sub test_macro()
Dim Fname As String
Fname = Sheets("Copy Transposed").Range("A1").Value
Sheets(Array("Test1", "Test2", "Test3", "Test4", "Test5")).copy
With ActiveWorkbook
ActiveWorkbook.SaveAs ThisWorkbook.path & "\" & Fname & ".xlsm", FileFormat:=52
End With
End Sub

I've checked this macro and it saves each workksheet seperatly but I want "Copy Transposed(4)" and "Test1", "Test2", "Test3", "Test4", "Test5" worksheets in 1 workbook — Adrian
Then change this part path & ws.Name to whatever you want. — braX

E. Merckx E. Merckx · Accepted Answer · 2017-11-21T15:45:20

I spot-tested the below macro, and got it to work. This macro looks for any worksheet with the string "Copy Transposed", and creates a workbook with the sheet found and with the sheets "Test1" thru "Test5". I imagine there are more elegant ways to achieve what you're looking for, but this seemed to work.

Sub Test()

Dim WS As Worksheet
Dim WB As Workbook
Dim SearchStr As String
Dim ShtName As String
Dim FName As String
Dim FPath As String
Dim WBNew As Workbook

Set WB = ActiveWorkbook

SearchStr = "Copy Transposed"
FPath = "C:\Users\hwyr53e\Desktop\Test Output\"

    For Each WS In WB.Sheets
        ShtName = WS.Name
        Set wshts = Sheets(Array("Test1", "Test2", "Test3", "Test4", "Test5"))
        If InStr(ShtName, SearchStr) > 0 Then
            FName = FPath & ShtName & ".xlsm"
            Set WBNew = Workbooks.Add
            wshts.Copy before:=WBNew.Sheets(1)
            WS.Copy before:=WBNew.Sheets(1)
            With WBNew
                .SaveAs FName, FileFormat:=52
            End With
            WBNew.Close
            Set WBNew = Nothing
        End If
    Next WS

End Sub

You will probably want to add a component to delete the sheets that populate with a new instance of Excel.

Let me know if this accomplishes what you're trying to achieve.

divide and save worksheets as separate files

1 Answers