Hello,

I am using a modified version of Ron De Bruin's (shown below) to split a
workbook, create a new workbook for each sheet and then put each newly
created workbook into a new folder.

How can I modify this code to split all books in the current folder, then
perform the same function:

Thanks in advance,

Sub Copy_All_Sheets_To_New_Workbook()


Dim WbMain As Workbook
Dim Wb As Workbook
Dim sh As Worksheet
Dim DateString As String
Dim YearDateString As String
Dim FolderName As String


Application.ScreenUpdating = False
Application.EnableEvents = False

DateString = Format(Now, "yy-mm-dd hh-mm-ss")
YearDateString = Format(Now, "yy")
Set WbMain = ThisWorkbook

FolderName = WbMain.Path & "\" & Left(WbMain.Name, Len(WbMain.Name) - 4)
& " " & DateString
MkDir FolderName

For Each sh In WbMain.Worksheets
If sh.Visible = -1 Then
sh.Copy

'The line below stops truncation where cell length is greater than
255 characters.
ActiveSheet.Range("A1:AZ1000").Value = sh.Range("A1:AZ1000").Value
Set Wb = ActiveWorkbook

'Converts formulas to values.
With Wb.Sheets(1)
.UsedRange.Copy
.UsedRange.PasteSpecial xlPasteValues
.Cells(1).Select
Application.CutCopyMode = False
End With

Wb.SaveAs FolderName _
& "\" & "Renewq" & YearDateString & Wb.Sheets(1).Name
& ".xls"
Wb.Close True
End If
Next sh

MsgBox "Look in " & FolderName & " for the files"

Application.ScreenUpdating = True
Application.EnableEvents = True
End Sub

--
Thanks,
MarkN

Hi Mark

Test this one for the files in C:\Data

Sub Test_1()
Dim mybook As Workbook
Dim sourceRange As Range
Dim destrange As Range
Dim FNames As String
Dim MyPath As String
Dim SaveDriveDir As String

SaveDriveDir = CurDir

MyPath = "C:\Data"
'Add a slash at the end if the user forget
If Right(MyPath, 1) < "\" Then
MyPath = MyPath & "\"
End If

ChDrive MyPath
ChDir MyPath
FNames = Dir("*.xls")
If Len(FNames) = 0 Then
MsgBox "No files in the Directory"
ChDrive SaveDriveDir
ChDir SaveDriveDir
Exit Sub
End If

Application.ScreenUpdating = False
Application.EnableEvents = False

On Error GoTo CleanUp

Do While FNames < ""
Set mybook = Workbooks.Open(FNames)

DateString = Format(Now, "yy-mm-dd hh-mm-ss")

FolderName = mybook.Path & "\" & Left(mybook.Name, Len(mybook.Name) - 4) & " " & DateString
MkDir FolderName

For Each sh In mybook.Worksheets
If sh.Visible = -1 Then
sh.Copy
Set Wb = ActiveWorkbook

' Use also this to make values from the formulas
With Wb.Sheets(1)
.UsedRange.Copy
.UsedRange.PasteSpecial xlPasteValues
.Cells(1).Select
Application.CutCopyMode = False
End With

Wb.SaveAs FolderName _
& "\" & Wb.Sheets(1).Name & ".xls"
Wb.Close False
End If
Next sh

MsgBox "Look in " & FolderName & " for the files"

mybook.Close False
FNames = Dir()
Loop

CleanUp:
ChDrive SaveDriveDir
ChDir SaveDriveDir
Application.ScreenUpdating = True
Application.EnableEvents = True
End Sub

--
Regards Ron de Bruin
http://www.rondebruin.nl



"MarkN" wrote in message ...
Hello,

I am using a modified version of Ron De Bruin's (shown below) to split a
workbook, create a new workbook for each sheet and then put each newly
created workbook into a new folder.

How can I modify this code to split all books in the current folder, then
perform the same function:

Thanks in advance,

Sub Copy_All_Sheets_To_New_Workbook()


Dim WbMain As Workbook
Dim Wb As Workbook
Dim sh As Worksheet
Dim DateString As String
Dim YearDateString As String
Dim FolderName As String


Application.ScreenUpdating = False
Application.EnableEvents = False

DateString = Format(Now, "yy-mm-dd hh-mm-ss")
YearDateString = Format(Now, "yy")
Set WbMain = ThisWorkbook

FolderName = WbMain.Path & "\" & Left(WbMain.Name, Len(WbMain.Name) - 4)
& " " & DateString
MkDir FolderName

For Each sh In WbMain.Worksheets
If sh.Visible = -1 Then
sh.Copy

'The line below stops truncation where cell length is greater than
255 characters.
ActiveSheet.Range("A1:AZ1000").Value = sh.Range("A1:AZ1000").Value
Set Wb = ActiveWorkbook

'Converts formulas to values.
With Wb.Sheets(1)
.UsedRange.Copy
.UsedRange.PasteSpecial xlPasteValues
.Cells(1).Select
Application.CutCopyMode = False
End With

Wb.SaveAs FolderName _
& "\" & "Renewq" & YearDateString & Wb.Sheets(1).Name
& ".xls"
Wb.Close True
End If
Next sh

MsgBox "Look in " & FolderName & " for the files"

Application.ScreenUpdating = True
Application.EnableEvents = True
End Sub

--
Thanks,
MarkN

Thanks Ron
--
Thanks,
MarkN


"Ron de Bruin" wrote:

Hi Mark

Test this one for the files in C:\Data

Sub Test_1()
Dim mybook As Workbook
Dim sourceRange As Range
Dim destrange As Range
Dim FNames As String
Dim MyPath As String
Dim SaveDriveDir As String

SaveDriveDir = CurDir

MyPath = "C:\Data"
'Add a slash at the end if the user forget
If Right(MyPath, 1) < "\" Then
MyPath = MyPath & "\"
End If

ChDrive MyPath
ChDir MyPath
FNames = Dir("*.xls")
If Len(FNames) = 0 Then
MsgBox "No files in the Directory"
ChDrive SaveDriveDir
ChDir SaveDriveDir
Exit Sub
End If

Application.ScreenUpdating = False
Application.EnableEvents = False

On Error GoTo CleanUp

Do While FNames < ""
Set mybook = Workbooks.Open(FNames)

DateString = Format(Now, "yy-mm-dd hh-mm-ss")

FolderName = mybook.Path & "\" & Left(mybook.Name, Len(mybook.Name) - 4) & " " & DateString
MkDir FolderName

For Each sh In mybook.Worksheets
If sh.Visible = -1 Then
sh.Copy
Set Wb = ActiveWorkbook

' Use also this to make values from the formulas
With Wb.Sheets(1)
.UsedRange.Copy
.UsedRange.PasteSpecial xlPasteValues
.Cells(1).Select
Application.CutCopyMode = False
End With

Wb.SaveAs FolderName _
& "\" & Wb.Sheets(1).Name & ".xls"
Wb.Close False
End If
Next sh

MsgBox "Look in " & FolderName & " for the files"

mybook.Close False
FNames = Dir()
Loop

CleanUp:
ChDrive SaveDriveDir
ChDir SaveDriveDir
Application.ScreenUpdating = True
Application.EnableEvents = True
End Sub

--
Regards Ron de Bruin
http://www.rondebruin.nl



"MarkN" wrote in message ...
Hello,

I am using a modified version of Ron De Bruin's (shown below) to split a
workbook, create a new workbook for each sheet and then put each newly
created workbook into a new folder.

How can I modify this code to split all books in the current folder, then
perform the same function:

Thanks in advance,

Sub Copy_All_Sheets_To_New_Workbook()


Dim WbMain As Workbook
Dim Wb As Workbook
Dim sh As Worksheet
Dim DateString As String
Dim YearDateString As String
Dim FolderName As String


Application.ScreenUpdating = False
Application.EnableEvents = False

DateString = Format(Now, "yy-mm-dd hh-mm-ss")
YearDateString = Format(Now, "yy")
Set WbMain = ThisWorkbook

FolderName = WbMain.Path & "\" & Left(WbMain.Name, Len(WbMain.Name) - 4)
& " " & DateString
MkDir FolderName

For Each sh In WbMain.Worksheets
If sh.Visible = -1 Then
sh.Copy

'The line below stops truncation where cell length is greater than
255 characters.
ActiveSheet.Range("A1:AZ1000").Value = sh.Range("A1:AZ1000").Value
Set Wb = ActiveWorkbook

'Converts formulas to values.
With Wb.Sheets(1)
.UsedRange.Copy
.UsedRange.PasteSpecial xlPasteValues
.Cells(1).Select
Application.CutCopyMode = False
End With

Wb.SaveAs FolderName _
& "\" & "Renewq" & YearDateString & Wb.Sheets(1).Name
& ".xls"
Wb.Close True
End If
Next sh

MsgBox "Look in " & FolderName & " for the files"

Application.ScreenUpdating = True
Application.EnableEvents = True
End Sub

--
Thanks,
MarkN