Splitting a workbook

[MarkN]

I am using Ron Debruin's code below to split each sheet in a workbook into a
new book. It works well but cells containing more than 255 characters get
truncated. I understand that you can get around this by copying a range
rather than the whole sheet but I can't get it to work. Any help appreciated.

Sub Copy_All_Sheets_To_New_Workbook()
Dim WbMain As Workbook
Dim Wb As Workbook
Dim sh As Worksheet
Dim DateString As String
Dim FolderName As String

Application.ScreenUpdating = False
Application.EnableEvents = False

DateString = Format(Now, "yy-mm-dd hh-mm-ss")
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
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"
Application.ScreenUpdating = True
Application.EnableEvents = True
End Sub

 

[Dave Peterson]

Untested...

Sub Copy_All_Sheets_To_New_Workbook()
Dim WbMain As Workbook
Dim Wb As Workbook
Dim sh As Worksheet
Dim DateString As String
Dim FolderName As String
dim newWks as worksheet

Application.ScreenUpdating = False
Application.EnableEvents = False

DateString = Format(Now, "yy-mm-dd hh-mm-ss")
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

'added some stuff here
set newwks = activesheet

sh.cells.copy _
destination:=newwks.range("a1")

Set Wb = newwks.parent

'done with changes

' 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"
Application.ScreenUpdating = True
Application.EnableEvents = True
End Sub

 

[MarkN]

Thanks Dave,

I added the line
ActiveSheet.Range("A1:AZ1000").Value = sh.Range("A1:AZ1000").Value
to the original code and all was well.

--
Thanks again,
MarkN

Untested...

Sub Copy_All_Sheets_To_New_Workbook()
Dim WbMain As Workbook
Dim Wb As Workbook
Dim sh As Worksheet
Dim DateString As String
Dim FolderName As String
dim newWks as worksheet

Application.ScreenUpdating = False
Application.EnableEvents = False

DateString = Format(Now, "yy-mm-dd hh-mm-ss")
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

'added some stuff here
set newwks = activesheet

sh.cells.copy _
destination:=newwks.range("a1")

Set Wb = newwks.parent

'done with changes

' 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"
Application.ScreenUpdating = True
Application.EnableEvents = True
End Sub