Splitting a workbook
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 -- Thanks, MarkN |
Splitting a workbook
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 wrote: 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 -- Thanks, MarkN -- Dave Peterson |
Splitting a workbook
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 "Dave Peterson" wrote: 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 wrote: 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 -- Thanks, MarkN -- Dave Peterson |
All times are GMT +1. The time now is 04:46 AM. |
Powered by vBulletin® Copyright ©2000 - 2024, Jelsoft Enterprises Ltd.
ExcelBanter.com