I have been using this Ron de Bruin code all day long! i've learned a lot
today and now, before I turn in, I'm trying to get the code to do one more
trick for me, but I can't figure out how to do it. Basically, the code below
splits a large Workbook into several files, each with just one sheet. I
would really like to split the large Workbook into several smaller files, and
attach a summary sheet to each newly created file. The summary sheet is
named 'Sheet1'. Is there some way to append a Sheet1 to each newly created
file?

Sub Copy_Every_Sheet_To_New_Workbook()
'Working in 97-2007
Dim FileExtStr As String
Dim FileFormatNum As Long
Dim Sourcewb As Workbook
Dim Destwb As Workbook
Dim sh As Worksheet
Dim DateString As String
Dim FolderName As String

With Application
.ScreenUpdating = False
.EnableEvents = False
.Calculation = xlCalculationManual
End With

'Copy every sheet from the workbook with this macro
Set Sourcewb = ThisWorkbook

'Create new folder to save the new files in
DateString = Format(Now, "yyyy-mm-dd")
FolderName = Sourcewb.Path & "\" & Sourcewb.Name & " " & DateString
MkDir FolderName

'Copy every visible sheet to a new workbook
For Each sh In Sourcewb.Worksheets

'If the sheet is visible then copy it to a new workbook
If sh.Visible = -1 Then
sh.Copy

'Set Destwb to the new workbook
Set Destwb = ActiveWorkbook

'Determine the Excel version and file extension/format
With Destwb
If Val(Application.Version) < 12 Then
'You use Excel 97-2003
FileExtStr = ".xls": FileFormatNum = -4143
Else
'You use Excel 2007
If Sourcewb.Name = .Name Then
MsgBox "Your answer is NO in the security dialog"
GoTo GoToNextSheet
Else
Select Case Sourcewb.FileFormat
Case 51: FileExtStr = ".xlsx": FileFormatNum = 51
Case 52:
If .HasVBProject Then
FileExtStr = ".xlsm": FileFormatNum = 52
Else
FileExtStr = ".xlsx": FileFormatNum = 51
End If
Case 56: FileExtStr = ".xls": FileFormatNum = 56
Case Else: FileExtStr = ".xlsb": FileFormatNum = 50
End Select
End If
End If
End With

'Change all cells in the worksheet to values if you want
If Destwb.Sheets(1).ProtectContents = False Then
With Destwb.Sheets(1).UsedRange
.Cells.Copy
.Cells.PasteSpecial xlPasteValues
.Cells(1).Select
End With
Application.CutCopyMode = False
End If


'Save the new workbook and close it
With Destwb
.SaveAs FolderName _
& "\" & Destwb.Sheets(1).Name & FileExtStr, _
FileFormat:=FileFormatNum
.Close False
End With

End If
GoToNextSheet:
Next sh

MsgBox "You can find the files in " & FolderName

With Application
.ScreenUpdating = True
.EnableEvents = True
.Calculation = xlCalculationAutomatic
End With
End Sub

Regards,
Ryan---


--
RyGuy

Ron's code uses "Destwb.Sheets(1)" in a few places. This means he's looking at
the leftmost sheet in the workbook.

If you copy the summary sheet so it's the second sheet, then you don't have to
change his code:

(Untested, uncompiled!)

Option Explicit
Sub Copy_Every_Sheet_To_New_Workbook()
'Working in 97-2007
Dim FileExtStr As String
Dim FileFormatNum As Long
Dim Sourcewb As Workbook
Dim Destwb As Workbook
Dim sh As Worksheet
Dim DateString As String
Dim FolderName As String

With Application
.ScreenUpdating = False
.EnableEvents = False
.Calculation = xlCalculationManual
End With

'Copy every sheet from the workbook with this macro
Set Sourcewb = ThisWorkbook

'Create new folder to save the new files in
DateString = Format(Now, "yyyy-mm-dd")
FolderName = Sourcewb.Path & "\" & Sourcewb.Name & " " & DateString
MkDir FolderName

'Copy every visible sheet to a new workbook
For Each sh In Sourcewb.Worksheets
If LCase(sh.Name) = LCase("sheet1") Then
'skip it
Else
'If the sheet is visible then copy it to a new workbook
If sh.Visible = -1 Then
'copy the summary sheet
Sourcewb.Sheets("sheet1").Copy

'Set Destwb to the new workbook
Set Destwb = ActiveWorkbook

'copy the real sheet
sh.Copy _
befo=Destwb.Sheets(1)

'Determine the Excel version and file extension/format
With Destwb
If Val(Application.Version) < 12 Then
'You use Excel 97-2003
FileExtStr = ".xls": FileFormatNum = -4143
Else
'You use Excel 2007
If Sourcewb.Name = .Name Then
MsgBox "Your answer is NO in the security dialog"
GoTo GoToNextSheet
Else
Select Case Sourcewb.FileFormat
Case 51: FileExtStr = ".xlsx": FileFormatNum = 51
Case 52:
If .HasVBProject Then
FileExtStr = ".xlsm": FileFormatNum = 52
Else
FileExtStr = ".xlsx": FileFormatNum = 51
End If
Case 56: FileExtStr = ".xls": FileFormatNum = 56
Case Else: FileExtStr = ".xlsb": FileFormatNum = 50
End Select
End If
End If
End With

'Change all cells in the worksheet to values if you want
If Destwb.Sheets(1).ProtectContents = False Then
With Destwb.Sheets(1).UsedRange
.Cells.Copy
.Cells.PasteSpecial xlPasteValues
.Cells(1).Select
End With
Application.CutCopyMode = False
End If


'Save the new workbook and close it
With Destwb
.SaveAs FolderName _
& "\" & Destwb.Sheets(1).Name & FileExtStr, _
FileFormat:=FileFormatNum
.Close False
End With

End If
GoToNextSheet:
Next sh

MsgBox "You can find the files in " & FolderName

With Application
.ScreenUpdating = True
.EnableEvents = True
.Calculation = xlCalculationAutomatic
End With
End Sub

===========
If you want the summary sheet as the first sheet, you can change:

sh.Copy _
befo=Destwb.Sheets(1)

to

sh.Copy _
after:=Destwb.Sheets(1)

But remember to change all those other
Destwb.Sheets(1)
to
Destwb.Sheets(2)



ryguy7272 wrote:

I have been using this Ron de Bruin code all day long! i've learned a lot
today and now, before I turn in, I'm trying to get the code to do one more
trick for me, but I can't figure out how to do it. Basically, the code below
splits a large Workbook into several files, each with just one sheet. I
would really like to split the large Workbook into several smaller files, and
attach a summary sheet to each newly created file. The summary sheet is
named 'Sheet1'. Is there some way to append a Sheet1 to each newly created
file?

Sub Copy_Every_Sheet_To_New_Workbook()
'Working in 97-2007
Dim FileExtStr As String
Dim FileFormatNum As Long
Dim Sourcewb As Workbook
Dim Destwb As Workbook
Dim sh As Worksheet
Dim DateString As String
Dim FolderName As String

With Application
.ScreenUpdating = False
.EnableEvents = False
.Calculation = xlCalculationManual
End With

'Copy every sheet from the workbook with this macro
Set Sourcewb = ThisWorkbook

'Create new folder to save the new files in
DateString = Format(Now, "yyyy-mm-dd")
FolderName = Sourcewb.Path & "\" & Sourcewb.Name & " " & DateString
MkDir FolderName

'Copy every visible sheet to a new workbook
For Each sh In Sourcewb.Worksheets

'If the sheet is visible then copy it to a new workbook
If sh.Visible = -1 Then
sh.Copy

'Set Destwb to the new workbook
Set Destwb = ActiveWorkbook

'Determine the Excel version and file extension/format
With Destwb
If Val(Application.Version) < 12 Then
'You use Excel 97-2003
FileExtStr = ".xls": FileFormatNum = -4143
Else
'You use Excel 2007
If Sourcewb.Name = .Name Then
MsgBox "Your answer is NO in the security dialog"
GoTo GoToNextSheet
Else
Select Case Sourcewb.FileFormat
Case 51: FileExtStr = ".xlsx": FileFormatNum = 51
Case 52:
If .HasVBProject Then
FileExtStr = ".xlsm": FileFormatNum = 52
Else
FileExtStr = ".xlsx": FileFormatNum = 51
End If
Case 56: FileExtStr = ".xls": FileFormatNum = 56
Case Else: FileExtStr = ".xlsb": FileFormatNum = 50
End Select
End If
End If
End With

'Change all cells in the worksheet to values if you want
If Destwb.Sheets(1).ProtectContents = False Then
With Destwb.Sheets(1).UsedRange
.Cells.Copy
.Cells.PasteSpecial xlPasteValues
.Cells(1).Select
End With
Application.CutCopyMode = False
End If

'Save the new workbook and close it
With Destwb
.SaveAs FolderName _
& "\" & Destwb.Sheets(1).Name & FileExtStr, _
FileFormat:=FileFormatNum
.Close False
End With

End If
GoToNextSheet:
Next sh

MsgBox "You can find the files in " & FolderName

With Application
.ScreenUpdating = True
.EnableEvents = True
.Calculation = xlCalculationAutomatic
End With
End Sub

Regards,
Ryan---

--
RyGuy

--

Dave Peterson

Thanks Dave!! Thanks for the other stuff too. I figured it could be done,
but I wasn't sure how to get it done. The code that you posted doesn't work,
but I'll try to fiddle with it a bit and get it resolved. If you get a
chance, please review the syntax. I get a message that says 'Compile Error.
Next Without For'.

The error occurs he
Next sh

I'm not sure what triggers this because, as far as I can tell, the For Next
loop is intact.
For Each sh In Sourcewb.Worksheets
....
Next sh

Does anyone know what may cause this?

Regards,
Ryan--



--
RyGuy


"Dave Peterson" wrote:

Ron's code uses "Destwb.Sheets(1)" in a few places. This means he's looking at
the leftmost sheet in the workbook.

If you copy the summary sheet so it's the second sheet, then you don't have to
change his code:

(Untested, uncompiled!)

Option Explicit
Sub Copy_Every_Sheet_To_New_Workbook()
'Working in 97-2007
Dim FileExtStr As String
Dim FileFormatNum As Long
Dim Sourcewb As Workbook
Dim Destwb As Workbook
Dim sh As Worksheet
Dim DateString As String
Dim FolderName As String

With Application
.ScreenUpdating = False
.EnableEvents = False
.Calculation = xlCalculationManual
End With

'Copy every sheet from the workbook with this macro
Set Sourcewb = ThisWorkbook

'Create new folder to save the new files in
DateString = Format(Now, "yyyy-mm-dd")
FolderName = Sourcewb.Path & "\" & Sourcewb.Name & " " & DateString
MkDir FolderName

'Copy every visible sheet to a new workbook
For Each sh In Sourcewb.Worksheets
If LCase(sh.Name) = LCase("sheet1") Then
'skip it
Else
'If the sheet is visible then copy it to a new workbook
If sh.Visible = -1 Then
'copy the summary sheet
Sourcewb.Sheets("sheet1").Copy

'Set Destwb to the new workbook
Set Destwb = ActiveWorkbook

'copy the real sheet
sh.Copy _
befo=Destwb.Sheets(1)

'Determine the Excel version and file extension/format
With Destwb
If Val(Application.Version) < 12 Then
'You use Excel 97-2003
FileExtStr = ".xls": FileFormatNum = -4143
Else
'You use Excel 2007
If Sourcewb.Name = .Name Then
MsgBox "Your answer is NO in the security dialog"
GoTo GoToNextSheet
Else
Select Case Sourcewb.FileFormat
Case 51: FileExtStr = ".xlsx": FileFormatNum = 51
Case 52:
If .HasVBProject Then
FileExtStr = ".xlsm": FileFormatNum = 52
Else
FileExtStr = ".xlsx": FileFormatNum = 51
End If
Case 56: FileExtStr = ".xls": FileFormatNum = 56
Case Else: FileExtStr = ".xlsb": FileFormatNum = 50
End Select
End If
End If
End With

'Change all cells in the worksheet to values if you want
If Destwb.Sheets(1).ProtectContents = False Then
With Destwb.Sheets(1).UsedRange
.Cells.Copy
.Cells.PasteSpecial xlPasteValues
.Cells(1).Select
End With
Application.CutCopyMode = False
End If


'Save the new workbook and close it
With Destwb
.SaveAs FolderName _
& "\" & Destwb.Sheets(1).Name & FileExtStr, _
FileFormat:=FileFormatNum
.Close False
End With

End If
GoToNextSheet:
Next sh

MsgBox "You can find the files in " & FolderName

With Application
.ScreenUpdating = True
.EnableEvents = True
.Calculation = xlCalculationAutomatic
End With
End Sub

===========
If you want the summary sheet as the first sheet, you can change:

sh.Copy _
befo=Destwb.Sheets(1)

to

sh.Copy _
after:=Destwb.Sheets(1)

But remember to change all those other
Destwb.Sheets(1)
to
Destwb.Sheets(2)



ryguy7272 wrote:

I have been using this Ron de Bruin code all day long! i've learned a lot
today and now, before I turn in, I'm trying to get the code to do one more
trick for me, but I can't figure out how to do it. Basically, the code below
splits a large Workbook into several files, each with just one sheet. I
would really like to split the large Workbook into several smaller files, and
attach a summary sheet to each newly created file. The summary sheet is
named 'Sheet1'. Is there some way to append a Sheet1 to each newly created
file?

Sub Copy_Every_Sheet_To_New_Workbook()
'Working in 97-2007
Dim FileExtStr As String
Dim FileFormatNum As Long
Dim Sourcewb As Workbook
Dim Destwb As Workbook
Dim sh As Worksheet
Dim DateString As String
Dim FolderName As String

With Application
.ScreenUpdating = False
.EnableEvents = False
.Calculation = xlCalculationManual
End With

'Copy every sheet from the workbook with this macro
Set Sourcewb = ThisWorkbook

'Create new folder to save the new files in
DateString = Format(Now, "yyyy-mm-dd")
FolderName = Sourcewb.Path & "\" & Sourcewb.Name & " " & DateString
MkDir FolderName

'Copy every visible sheet to a new workbook
For Each sh In Sourcewb.Worksheets

'If the sheet is visible then copy it to a new workbook
If sh.Visible = -1 Then
sh.Copy

'Set Destwb to the new workbook
Set Destwb = ActiveWorkbook

'Determine the Excel version and file extension/format
With Destwb
If Val(Application.Version) < 12 Then
'You use Excel 97-2003
FileExtStr = ".xls": FileFormatNum = -4143
Else
'You use Excel 2007
If Sourcewb.Name = .Name Then
MsgBox "Your answer is NO in the security dialog"
GoTo GoToNextSheet
Else
Select Case Sourcewb.FileFormat
Case 51: FileExtStr = ".xlsx": FileFormatNum = 51
Case 52:
If .HasVBProject Then
FileExtStr = ".xlsm": FileFormatNum = 52
Else
FileExtStr = ".xlsx": FileFormatNum = 51
End If
Case 56: FileExtStr = ".xls": FileFormatNum = 56
Case Else: FileExtStr = ".xlsb": FileFormatNum = 50
End Select
End If
End If
End With

'Change all cells in the worksheet to values if you want
If Destwb.Sheets(1).ProtectContents = False Then
With Destwb.Sheets(1).UsedRange
.Cells.Copy
.Cells.PasteSpecial xlPasteValues
.Cells(1).Select
End With
Application.CutCopyMode = False
End If

'Save the new workbook and close it
With Destwb
.SaveAs FolderName _
& "\" & Destwb.Sheets(1).Name & FileExtStr, _
FileFormat:=FileFormatNum
.Close False
End With

End If
GoToNextSheet:
Next sh

MsgBox "You can find the files in " & FolderName

With Application
.ScreenUpdating = True
.EnableEvents = True
.Calculation = xlCalculationAutomatic
End With
End Sub

Regards,
Ryan---

--
RyGuy

--

Dave Peterson

I left out an "end if":

End With

End If
End If '<-- added this one
GoToNextSheet:
Next sh

ryguy7272 wrote:

Thanks Dave!! Thanks for the other stuff too. I figured it could be done,
but I wasn't sure how to get it done. The code that you posted doesn't work,
but I'll try to fiddle with it a bit and get it resolved. If you get a
chance, please review the syntax. I get a message that says 'Compile Error.
Next Without For'.

The error occurs he
Next sh

I'm not sure what triggers this because, as far as I can tell, the For Next
loop is intact.
For Each sh In Sourcewb.Worksheets
...
Next sh

Does anyone know what may cause this?

Regards,
Ryan--

--
RyGuy

"Dave Peterson" wrote:

Ron's code uses "Destwb.Sheets(1)" in a few places. This means he's looking at
the leftmost sheet in the workbook.

If you copy the summary sheet so it's the second sheet, then you don't have to
change his code:

(Untested, uncompiled!)

Option Explicit
Sub Copy_Every_Sheet_To_New_Workbook()
'Working in 97-2007
Dim FileExtStr As String
Dim FileFormatNum As Long
Dim Sourcewb As Workbook
Dim Destwb As Workbook
Dim sh As Worksheet
Dim DateString As String
Dim FolderName As String

With Application
.ScreenUpdating = False
.EnableEvents = False
.Calculation = xlCalculationManual
End With

'Copy every sheet from the workbook with this macro
Set Sourcewb = ThisWorkbook

'Create new folder to save the new files in
DateString = Format(Now, "yyyy-mm-dd")
FolderName = Sourcewb.Path & "\" & Sourcewb.Name & " " & DateString
MkDir FolderName

'Copy every visible sheet to a new workbook
For Each sh In Sourcewb.Worksheets
If LCase(sh.Name) = LCase("sheet1") Then
'skip it
Else
'If the sheet is visible then copy it to a new workbook
If sh.Visible = -1 Then
'copy the summary sheet
Sourcewb.Sheets("sheet1").Copy

'Set Destwb to the new workbook
Set Destwb = ActiveWorkbook

'copy the real sheet
sh.Copy _
befo=Destwb.Sheets(1)

'Determine the Excel version and file extension/format
With Destwb
If Val(Application.Version) < 12 Then
'You use Excel 97-2003
FileExtStr = ".xls": FileFormatNum = -4143
Else
'You use Excel 2007
If Sourcewb.Name = .Name Then
MsgBox "Your answer is NO in the security dialog"
GoTo GoToNextSheet
Else
Select Case Sourcewb.FileFormat
Case 51: FileExtStr = ".xlsx": FileFormatNum = 51
Case 52:
If .HasVBProject Then
FileExtStr = ".xlsm": FileFormatNum = 52
Else
FileExtStr = ".xlsx": FileFormatNum = 51
End If
Case 56: FileExtStr = ".xls": FileFormatNum = 56
Case Else: FileExtStr = ".xlsb": FileFormatNum = 50
End Select
End If
End If
End With

'Change all cells in the worksheet to values if you want
If Destwb.Sheets(1).ProtectContents = False Then
With Destwb.Sheets(1).UsedRange
.Cells.Copy
.Cells.PasteSpecial xlPasteValues
.Cells(1).Select
End With
Application.CutCopyMode = False
End If


'Save the new workbook and close it
With Destwb
.SaveAs FolderName _
& "\" & Destwb.Sheets(1).Name & FileExtStr, _
FileFormat:=FileFormatNum
.Close False
End With

End If
GoToNextSheet:
Next sh

MsgBox "You can find the files in " & FolderName

With Application
.ScreenUpdating = True
.EnableEvents = True
.Calculation = xlCalculationAutomatic
End With
End Sub

===========
If you want the summary sheet as the first sheet, you can change:

sh.Copy _
befo=Destwb.Sheets(1)

to

sh.Copy _
after:=Destwb.Sheets(1)

But remember to change all those other
Destwb.Sheets(1)
to
Destwb.Sheets(2)



ryguy7272 wrote:

I have been using this Ron de Bruin code all day long! i've learned a lot
today and now, before I turn in, I'm trying to get the code to do one more
trick for me, but I can't figure out how to do it. Basically, the code below
splits a large Workbook into several files, each with just one sheet. I
would really like to split the large Workbook into several smaller files, and
attach a summary sheet to each newly created file. The summary sheet is
named 'Sheet1'. Is there some way to append a Sheet1 to each newly created
file?

Sub Copy_Every_Sheet_To_New_Workbook()
'Working in 97-2007
Dim FileExtStr As String
Dim FileFormatNum As Long
Dim Sourcewb As Workbook
Dim Destwb As Workbook
Dim sh As Worksheet
Dim DateString As String
Dim FolderName As String

With Application
.ScreenUpdating = False
.EnableEvents = False
.Calculation = xlCalculationManual
End With

'Copy every sheet from the workbook with this macro
Set Sourcewb = ThisWorkbook

'Create new folder to save the new files in
DateString = Format(Now, "yyyy-mm-dd")
FolderName = Sourcewb.Path & "\" & Sourcewb.Name & " " & DateString
MkDir FolderName

'Copy every visible sheet to a new workbook
For Each sh In Sourcewb.Worksheets

'If the sheet is visible then copy it to a new workbook
If sh.Visible = -1 Then
sh.Copy

'Set Destwb to the new workbook
Set Destwb = ActiveWorkbook

'Determine the Excel version and file extension/format
With Destwb
If Val(Application.Version) < 12 Then
'You use Excel 97-2003
FileExtStr = ".xls": FileFormatNum = -4143
Else
'You use Excel 2007
If Sourcewb.Name = .Name Then
MsgBox "Your answer is NO in the security dialog"
GoTo GoToNextSheet
Else
Select Case Sourcewb.FileFormat
Case 51: FileExtStr = ".xlsx": FileFormatNum = 51
Case 52:
If .HasVBProject Then
FileExtStr = ".xlsm": FileFormatNum = 52
Else
FileExtStr = ".xlsx": FileFormatNum = 51
End If
Case 56: FileExtStr = ".xls": FileFormatNum = 56
Case Else: FileExtStr = ".xlsb": FileFormatNum = 50
End Select
End If
End If
End With

'Change all cells in the worksheet to values if you want
If Destwb.Sheets(1).ProtectContents = False Then
With Destwb.Sheets(1).UsedRange
.Cells.Copy
.Cells.PasteSpecial xlPasteValues
.Cells(1).Select
End With
Application.CutCopyMode = False
End If

'Save the new workbook and close it
With Destwb
.SaveAs FolderName _
& "\" & Destwb.Sheets(1).Name & FileExtStr, _
FileFormat:=FileFormatNum
.Close False
End With

End If
GoToNextSheet:
Next sh

MsgBox "You can find the files in " & FolderName

With Application
.ScreenUpdating = True
.EnableEvents = True
.Calculation = xlCalculationAutomatic
End With
End Sub

Regards,
Ryan---

--
RyGuy

--

Dave Peterson


--

Dave Peterson

Daaaammmmnnnnnn!! That is so powerful!!
Thanks a ton for the help Dave.
I wonder why the End If caused the For...Next error.
I'll have to read up on this some more.

Again, thanks for everything!!


Regards,
Ryan--


--
RyGuy


"Dave Peterson" wrote:

I left out an "end if":

End With

End If
End If '<-- added this one
GoToNextSheet:
Next sh

ryguy7272 wrote:

Thanks Dave!! Thanks for the other stuff too. I figured it could be done,
but I wasn't sure how to get it done. The code that you posted doesn't work,
but I'll try to fiddle with it a bit and get it resolved. If you get a
chance, please review the syntax. I get a message that says 'Compile Error.
Next Without For'.

The error occurs he
Next sh

I'm not sure what triggers this because, as far as I can tell, the For Next
loop is intact.
For Each sh In Sourcewb.Worksheets
...
Next sh

Does anyone know what may cause this?

Regards,
Ryan--

--
RyGuy

"Dave Peterson" wrote:

Ron's code uses "Destwb.Sheets(1)" in a few places. This means he's looking at
the leftmost sheet in the workbook.

If you copy the summary sheet so it's the second sheet, then you don't have to
change his code:

(Untested, uncompiled!)

Option Explicit
Sub Copy_Every_Sheet_To_New_Workbook()
'Working in 97-2007
Dim FileExtStr As String
Dim FileFormatNum As Long
Dim Sourcewb As Workbook
Dim Destwb As Workbook
Dim sh As Worksheet
Dim DateString As String
Dim FolderName As String

With Application
.ScreenUpdating = False
.EnableEvents = False
.Calculation = xlCalculationManual
End With

'Copy every sheet from the workbook with this macro
Set Sourcewb = ThisWorkbook

'Create new folder to save the new files in
DateString = Format(Now, "yyyy-mm-dd")
FolderName = Sourcewb.Path & "\" & Sourcewb.Name & " " & DateString
MkDir FolderName

'Copy every visible sheet to a new workbook
For Each sh In Sourcewb.Worksheets
If LCase(sh.Name) = LCase("sheet1") Then
'skip it
Else
'If the sheet is visible then copy it to a new workbook
If sh.Visible = -1 Then
'copy the summary sheet
Sourcewb.Sheets("sheet1").Copy

'Set Destwb to the new workbook
Set Destwb = ActiveWorkbook

'copy the real sheet
sh.Copy _
befo=Destwb.Sheets(1)

'Determine the Excel version and file extension/format
With Destwb
If Val(Application.Version) < 12 Then
'You use Excel 97-2003
FileExtStr = ".xls": FileFormatNum = -4143
Else
'You use Excel 2007
If Sourcewb.Name = .Name Then
MsgBox "Your answer is NO in the security dialog"
GoTo GoToNextSheet
Else
Select Case Sourcewb.FileFormat
Case 51: FileExtStr = ".xlsx": FileFormatNum = 51
Case 52:
If .HasVBProject Then
FileExtStr = ".xlsm": FileFormatNum = 52
Else
FileExtStr = ".xlsx": FileFormatNum = 51
End If
Case 56: FileExtStr = ".xls": FileFormatNum = 56
Case Else: FileExtStr = ".xlsb": FileFormatNum = 50
End Select
End If
End If
End With

'Change all cells in the worksheet to values if you want
If Destwb.Sheets(1).ProtectContents = False Then
With Destwb.Sheets(1).UsedRange
.Cells.Copy
.Cells.PasteSpecial xlPasteValues
.Cells(1).Select
End With
Application.CutCopyMode = False
End If


'Save the new workbook and close it
With Destwb
.SaveAs FolderName _
& "\" & Destwb.Sheets(1).Name & FileExtStr, _
FileFormat:=FileFormatNum
.Close False
End With

End If
GoToNextSheet:
Next sh

MsgBox "You can find the files in " & FolderName

With Application
.ScreenUpdating = True
.EnableEvents = True
.Calculation = xlCalculationAutomatic
End With
End Sub

===========
If you want the summary sheet as the first sheet, you can change:

sh.Copy _
befo=Destwb.Sheets(1)

to

sh.Copy _
after:=Destwb.Sheets(1)

But remember to change all those other
Destwb.Sheets(1)
to
Destwb.Sheets(2)



ryguy7272 wrote:

I have been using this Ron de Bruin code all day long! i've learned a lot
today and now, before I turn in, I'm trying to get the code to do one more
trick for me, but I can't figure out how to do it. Basically, the code below
splits a large Workbook into several files, each with just one sheet. I
would really like to split the large Workbook into several smaller files, and
attach a summary sheet to each newly created file. The summary sheet is
named 'Sheet1'. Is there some way to append a Sheet1 to each newly created
file?

Sub Copy_Every_Sheet_To_New_Workbook()
'Working in 97-2007
Dim FileExtStr As String
Dim FileFormatNum As Long
Dim Sourcewb As Workbook
Dim Destwb As Workbook
Dim sh As Worksheet
Dim DateString As String
Dim FolderName As String

With Application
.ScreenUpdating = False
.EnableEvents = False
.Calculation = xlCalculationManual
End With

'Copy every sheet from the workbook with this macro
Set Sourcewb = ThisWorkbook

'Create new folder to save the new files in
DateString = Format(Now, "yyyy-mm-dd")
FolderName = Sourcewb.Path & "\" & Sourcewb.Name & " " & DateString
MkDir FolderName

'Copy every visible sheet to a new workbook
For Each sh In Sourcewb.Worksheets

'If the sheet is visible then copy it to a new workbook
If sh.Visible = -1 Then
sh.Copy

'Set Destwb to the new workbook
Set Destwb = ActiveWorkbook

'Determine the Excel version and file extension/format
With Destwb
If Val(Application.Version) < 12 Then
'You use Excel 97-2003
FileExtStr = ".xls": FileFormatNum = -4143
Else
'You use Excel 2007
If Sourcewb.Name = .Name Then
MsgBox "Your answer is NO in the security dialog"
GoTo GoToNextSheet
Else
Select Case Sourcewb.FileFormat
Case 51: FileExtStr = ".xlsx": FileFormatNum = 51
Case 52:
If .HasVBProject Then
FileExtStr = ".xlsm": FileFormatNum = 52
Else
FileExtStr = ".xlsx": FileFormatNum = 51
End If
Case 56: FileExtStr = ".xls": FileFormatNum = 56
Case Else: FileExtStr = ".xlsb": FileFormatNum = 50
End Select
End If
End If
End With

'Change all cells in the worksheet to values if you want
If Destwb.Sheets(1).ProtectContents = False Then
With Destwb.Sheets(1).UsedRange
.Cells.Copy
.Cells.PasteSpecial xlPasteValues
.Cells(1).Select
End With
Application.CutCopyMode = False
End If

'Save the new workbook and close it
With Destwb
.SaveAs FolderName _
& "\" & Destwb.Sheets(1).Name & FileExtStr, _
FileFormat:=FileFormatNum
.Close False
End With

End If
GoToNextSheet:
Next sh

MsgBox "You can find the files in " & FolderName

With Application
.ScreenUpdating = True
.EnableEvents = True
.Calculation = xlCalculationAutomatic
End With
End Sub

Regards,
Ryan---

--
RyGuy

--

Dave Peterson


--

Dave Peterson

Missing an "End With" or "end if" or any of those End statements can confuse
excel into not being able to know what you (er, I) really missed.

ryguy7272 wrote:

Daaaammmmnnnnnn!! That is so powerful!!
Thanks a ton for the help Dave.
I wonder why the End If caused the For...Next error.
I'll have to read up on this some more.

Again, thanks for everything!!

Regards,
Ryan--

--
RyGuy

"Dave Peterson" wrote:

I left out an "end if":

End With

End If
End If '<-- added this one
GoToNextSheet:
Next sh

ryguy7272 wrote:

Thanks Dave!! Thanks for the other stuff too. I figured it could be done,
but I wasn't sure how to get it done. The code that you posted doesn't work,
but I'll try to fiddle with it a bit and get it resolved. If you get a
chance, please review the syntax. I get a message that says 'Compile Error.
Next Without For'.

The error occurs he
Next sh

I'm not sure what triggers this because, as far as I can tell, the For Next
loop is intact.
For Each sh In Sourcewb.Worksheets
...
Next sh

Does anyone know what may cause this?

Regards,
Ryan--

--
RyGuy

"Dave Peterson" wrote:

Ron's code uses "Destwb.Sheets(1)" in a few places. This means he's looking at
the leftmost sheet in the workbook.

If you copy the summary sheet so it's the second sheet, then you don't have to
change his code:

(Untested, uncompiled!)

Option Explicit
Sub Copy_Every_Sheet_To_New_Workbook()
'Working in 97-2007
Dim FileExtStr As String
Dim FileFormatNum As Long
Dim Sourcewb As Workbook
Dim Destwb As Workbook
Dim sh As Worksheet
Dim DateString As String
Dim FolderName As String

With Application
.ScreenUpdating = False
.EnableEvents = False
.Calculation = xlCalculationManual
End With

'Copy every sheet from the workbook with this macro
Set Sourcewb = ThisWorkbook

'Create new folder to save the new files in
DateString = Format(Now, "yyyy-mm-dd")
FolderName = Sourcewb.Path & "\" & Sourcewb.Name & " " & DateString
MkDir FolderName

'Copy every visible sheet to a new workbook
For Each sh In Sourcewb.Worksheets
If LCase(sh.Name) = LCase("sheet1") Then
'skip it
Else
'If the sheet is visible then copy it to a new workbook
If sh.Visible = -1 Then
'copy the summary sheet
Sourcewb.Sheets("sheet1").Copy

'Set Destwb to the new workbook
Set Destwb = ActiveWorkbook

'copy the real sheet
sh.Copy _
befo=Destwb.Sheets(1)

'Determine the Excel version and file extension/format
With Destwb
If Val(Application.Version) < 12 Then
'You use Excel 97-2003
FileExtStr = ".xls": FileFormatNum = -4143
Else
'You use Excel 2007
If Sourcewb.Name = .Name Then
MsgBox "Your answer is NO in the security dialog"
GoTo GoToNextSheet
Else
Select Case Sourcewb.FileFormat
Case 51: FileExtStr = ".xlsx": FileFormatNum = 51
Case 52:
If .HasVBProject Then
FileExtStr = ".xlsm": FileFormatNum = 52
Else
FileExtStr = ".xlsx": FileFormatNum = 51
End If
Case 56: FileExtStr = ".xls": FileFormatNum = 56
Case Else: FileExtStr = ".xlsb": FileFormatNum = 50
End Select
End If
End If
End With

'Change all cells in the worksheet to values if you want
If Destwb.Sheets(1).ProtectContents = False Then
With Destwb.Sheets(1).UsedRange
.Cells.Copy
.Cells.PasteSpecial xlPasteValues
.Cells(1).Select
End With
Application.CutCopyMode = False
End If


'Save the new workbook and close it
With Destwb
.SaveAs FolderName _
& "\" & Destwb.Sheets(1).Name & FileExtStr, _
FileFormat:=FileFormatNum
.Close False
End With

End If
GoToNextSheet:
Next sh

MsgBox "You can find the files in " & FolderName

With Application
.ScreenUpdating = True
.EnableEvents = True
.Calculation = xlCalculationAutomatic
End With
End Sub

===========
If you want the summary sheet as the first sheet, you can change:

sh.Copy _
befo=Destwb.Sheets(1)

to

sh.Copy _
after:=Destwb.Sheets(1)

But remember to change all those other
Destwb.Sheets(1)
to
Destwb.Sheets(2)



ryguy7272 wrote:

I have been using this Ron de Bruin code all day long! i've learned a lot
today and now, before I turn in, I'm trying to get the code to do one more
trick for me, but I can't figure out how to do it. Basically, the code below
splits a large Workbook into several files, each with just one sheet. I
would really like to split the large Workbook into several smaller files, and
attach a summary sheet to each newly created file. The summary sheet is
named 'Sheet1'. Is there some way to append a Sheet1 to each newly created
file?

Sub Copy_Every_Sheet_To_New_Workbook()
'Working in 97-2007
Dim FileExtStr As String
Dim FileFormatNum As Long
Dim Sourcewb As Workbook
Dim Destwb As Workbook
Dim sh As Worksheet
Dim DateString As String
Dim FolderName As String

With Application
.ScreenUpdating = False
.EnableEvents = False
.Calculation = xlCalculationManual
End With

'Copy every sheet from the workbook with this macro
Set Sourcewb = ThisWorkbook

'Create new folder to save the new files in
DateString = Format(Now, "yyyy-mm-dd")
FolderName = Sourcewb.Path & "\" & Sourcewb.Name & " " & DateString
MkDir FolderName

'Copy every visible sheet to a new workbook
For Each sh In Sourcewb.Worksheets

'If the sheet is visible then copy it to a new workbook
If sh.Visible = -1 Then
sh.Copy

'Set Destwb to the new workbook
Set Destwb = ActiveWorkbook

'Determine the Excel version and file extension/format
With Destwb
If Val(Application.Version) < 12 Then
'You use Excel 97-2003
FileExtStr = ".xls": FileFormatNum = -4143
Else
'You use Excel 2007
If Sourcewb.Name = .Name Then
MsgBox "Your answer is NO in the security dialog"
GoTo GoToNextSheet
Else
Select Case Sourcewb.FileFormat
Case 51: FileExtStr = ".xlsx": FileFormatNum = 51
Case 52:
If .HasVBProject Then
FileExtStr = ".xlsm": FileFormatNum = 52
Else
FileExtStr = ".xlsx": FileFormatNum = 51
End If
Case 56: FileExtStr = ".xls": FileFormatNum = 56
Case Else: FileExtStr = ".xlsb": FileFormatNum = 50
End Select
End If
End If
End With

'Change all cells in the worksheet to values if you want
If Destwb.Sheets(1).ProtectContents = False Then
With Destwb.Sheets(1).UsedRange
.Cells.Copy
.Cells.PasteSpecial xlPasteValues
.Cells(1).Select
End With
Application.CutCopyMode = False
End If

'Save the new workbook and close it
With Destwb
.SaveAs FolderName _
& "\" & Destwb.Sheets(1).Name & FileExtStr, _
FileFormat:=FileFormatNum
.Close False
End With

End If
GoToNextSheet:
Next sh

MsgBox "You can find the files in " & FolderName

With Application
.ScreenUpdating = True
.EnableEvents = True
.Calculation = xlCalculationAutomatic
End With
End Sub

Regards,
Ryan---

--
RyGuy

--

Dave Peterson


--

Dave Peterson


--

Dave Peterson