Save multiple files with 3 worksheets

Alintm · Apr 12th 2020

Hi,

I need a help here ... if it's possible ....[Blocked Image: https://www.excelforum.com/images/smilies/frown.gif]

I have a file with 100 worksheets

worksheet1 - "Master"

worksheet2 - "Sheet2"

worksheet3 - "Instructions"

worksheet4 - "Headers"

worksheet5 - "tabel1"

worksheet6 - "tabel2"

worksheet7 - "tabel3"

.......

worksheet100 - "tabel96"

I use below code:

Code:

Code

Sub SplitEachWorksheet()
Dim FPath As String
FPath = Application.ActiveWorkbook.Path
Application.ScreenUpdating = False
Application.DisplayAlerts = False
For Each ws In ThisWorkbook.Sheets    ws.Copy    Application.ActiveWorkbook.SaveAs Filename:=FPath & "\" & ws.Name & ".xlsx"    Application.ActiveWorkbook.Close False
Next
Application.DisplayAlerts = True
Application.ScreenUpdating = True
End Sub

it works, the code will create 96 files (named after the worksheet name) only with 1 worksheet.

I don't know how to change the code it but I need to create 96 separately file with 3 worksheets:

file1:

worksheet1 - "Instructions"

worksheet2 - "Headers"

worksheet3 - should be named "Items" - with the info from "tabel1"

file2:

worksheet1 - "Instructions"

worksheet2 - "Headers"

worksheet3 - should be named "Items" - with the info from "tabel2"

...........

file96

worksheet1 - "Instructions"

worksheet2 - "Headers"

worksheet3 - should be named "Items" - with the info from "tabel96"

Thank you!

jolivanes · Apr 13th 2020

Try

Code

Sub Maybe()
Dim i As Long
Dim FPath As String
Application.ScreenUpdating = False
Application.DisplayAlerts = False
FPath = Application.ThisWorkbook.Path
For i = 1 To 96
Sheets(Array("Instructions", "Headers", "tabel" & i)).Copy
ActiveWorkbook.SaveAs Filename:=FPath & "\" & "Table " & i & ".xlsx"
ActiveWorkbook.Sheets(3).Name = "Items"
ActiveWorkbook.Close True
wb1.Sheets("Master").Select
Next i
Application.DisplayAlerts = False
Application.ScreenUpdating = True
End Sub

Display More

jolivanes · Apr 13th 2020

Copied the wrong code before (previous post).

This should do the trick.

Code

Sub Maybe()
Dim i As Long
Dim FPath As String
Dim wb1 As Workbook
Application.ScreenUpdating = False
Application.DisplayAlerts = False
Set wb1 = ThisWorkbook
FPath = Application.ThisWorkbook.Path
For i = 1 To 5    '96
Sheets(Array("Instructions", "Headers", "tabel" & i)).Copy
With ActiveWorkbook
.SaveAs Filename:=FPath & "\" & "Table " & i & ".xlsx"
.Sheets(3).Name = "Items"
.Close True
End With
wb1.Sheets("Master").Select
Next i
Application.DisplayAlerts = False
Application.ScreenUpdating = True
End Sub

Display More

Alintm · Apr 13th 2020

Hi, thank you for the code, but I missed something important! My fault!

The name of worksheets are different (such BTYD, TGUM, RCDA, etc... they could be maximum 150 wks. The names of the new files should be BTYD.xlsx, TGUM.xlsx, RCDA.xlsx, etc... and they need contains 3 wks identically: Headers, Instructions and Items (the information in Items in first new file should be info from wks BTYD and so on...)

I realize this thing when I put the code:

Sheets(Array("Instructions", "Headers", "tabel" & i)).Copy but I don't have such a wks with name "tabel" & i

I really appreciate your effort!

Thanks again!

jolivanes · Apr 13th 2020

From post #1

worksheet5 - "tabel1"

It is beauty sleep time here so if someone else does not come up with something, I'll have a look tomorrow.

Alintm · Apr 13th 2020

Thanks again!

jolivanes · Apr 13th 2020

Try this.

Code

Sub Maybe()
Dim i As Long
Dim FPath As String
Dim wb1 As Workbook
If ThisWorkbook.Sheets.Count = 4 Then MsgBox "Insufficient sheets to run this macro!": Exit Sub
Application.ScreenUpdating = False
Application.DisplayAlerts = False
Set wb1 = ThisWorkbook
FPath = Application.ThisWorkbook.Path
For i = 5 To wb1.Worksheets.Count
wb1.Sheets(Array("Instructions", "Headers", Sheets(i).Name)).Copy
With ActiveWorkbook
.SaveAs Filename:=FPath & "\" & wb1.Sheets(i).Name & ".xlsx"
.Sheets(3).Name = "Items"
.Close True
End With
Next i
Application.DisplayAlerts = False
Application.ScreenUpdating = True
End Sub

Display More

Alintm · Apr 13th 2020

Many thanks !!!!

it's working !!!

I really appreciate your effort!

jolivanes · Apr 13th 2020

Thanks for letting us know and good luck

Stay safe.

Save multiple files with 3 worksheets

Participate now!

Share

Tags

Users Viewing This Thread