Home |
Search |
Today's Posts |
|
#1
![]() |
|||
|
|||
![]() Quote:
Private Sub Workbook_Open() Call Copy_Every_Sheet_To_New_Workbook End Sub 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 hh-mm-ss") 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 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 FileFormatNum = InputBox("enter the version number for", "versioning", "xlsx - 51, xlsm - 52,xls - 56,xlsb - 50") '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
__________________
Thanks Bala |
Reply |
Thread Tools | Search this Thread |
Display Modes | |
|
|
![]() |
||||
Thread | Forum | |||
Taking specific rows from on workbook to create another workbook | Excel Worksheet Functions | |||
Taking a workbook out of Data Tracking | Excel Worksheet Functions | |||
Multiple Sheets (Need to create 500 individual sheets in one workbook, pulling DATA | Excel Worksheet Functions | |||
add new sheets in a workbook with new sheets being a variable | Excel Discussion (Misc queries) | |||
How to repeat a code for selected sheets (or a contiguous range of sheets) in a Workbook? | Excel Worksheet Functions |