I am trying to create multiple Excel workbooks by separating out each worksheet in a single workbook with:
Sub Splitbook()
MyPath = ThisWorkbook.Path
For Each sht In ThisWorkbook.Sheets
sht.Copy
'(I got an error here-copy method of worksheet class failed)
ActiveSheet.Cells.Copy
ActiveSheet.Cells.PasteSpecial Paste:=xlPasteValues
ActiveSheet.Cells.PasteSpecial Paste:=xlPasteFormats
ActiveWorkbook.SaveAs _
Filename:=MyPath & "\" & sht.Name & ".xls"
ActiveWorkbook.Close savechanges:=False
Next sht
End Sub
I have used the same code for a different workbook and it worked but am now seeing the copy method of worksheet class failed error.
Can anyone explain why and how to fix this please?
There are several complications with your code in order to perform the described task. I have modified your code in order to make it create individual workbooks out of all the worksheets in your active workbook.
Sub Splitbook()
Dim CurWb As Workbook, NewWb As Workbook
Dim MyPath As String
MyPath = ActiveWorkbook.Path
Set CurWb = ActiveWorkbook
Application.ScreenUpdating = False
'Loops through all sheets in active workbook
For Each CurWs In CurWb.Worksheets
'Copy sheet to new workbook
CurWb.Sheets(CurWs.Name).Copy After:=Workbooks.Add.Sheets(1)
Set NewWb = ActiveWorkbook
'Removes empty sheets, saves workbook and closes workbook
Application.DisplayAlerts = False
For Each NewWs In NewWb.Worksheets
If NewWs.Name <> CurWs.Name Then NewWs.Delete
Next NewWs
NewWb.SaveAs Filename:=MyPath & "\" & CurWs.Name & ".xls", FileFormat:=56
NewWb.Close SaveChanges:=False
Application.DisplayAlerts = True
Next CurWs
Application.ScreenUpdating = True
End Sub
I have modified your code to check the sheet which is copied is visible. Please give this a try and let me know the results.
Sub Splitbook()
MyPath = ThisWorkbook.Path
For Each sht In ThisWorkbook.Sheets
If sht.Visible = True Then
sht.Copy
'(I got an error here-copy method of worksheet class failed)
ActiveSheet.Cells.Copy
ActiveSheet.Cells.PasteSpecial Paste:=xlPasteValues
ActiveSheet.Cells.PasteSpecial Paste:=xlPasteFormats
ActiveWorkbook.SaveAs _
Filename:=MyPath & "\" & sht.Name & ".xls"
ActiveWorkbook.Close savechanges:=False
End If
Next sht
End Sub
Related
I am trying to copy a dynamic range(dyna) from activesheet and paste it to a new workbook located in "E:\1b\", file name based on cell value(J7).
Below is the formula in the dynamic range:
dyna = "=OFFSET(Sheet1!$D$6,0,0,COUNTA(Sheet1!$D:$J),7)"
I need help to do it.
here is code I have
Set wb = Workbooks.Add
ThisWorkbook.Activate
ActiveSheet.dyna.Copy Before:=wb.Sheets(1)
wb.Activate
Application.DisplayAlerts = False
wb.SaveAs "E:\1b\" & Range("J7").Value & ".xlsx",
FileFormat:=xlOpenXMLWorkbook, ReadOnlyRecommended:=False, CreateBackup:=False
wb.Close "E:\1b\" & Range("J7").Value & ".xlsx"
Application.DisplayAlerts = True
End Sub
I need to convert all sheets within a excel file to csv . I also need to delete the top two rows. Output file to should be saved in folder (ProductSheets) to be created within the existing original file location.
I tried below code but on running the code leaves all sheets opened individually which i have to manually close it.
Sub ExportSheetsToCSV()
Application.DisplayAlerts = False
Dim newWs As Worksheet
Dim CurrentWB As Workbook, TempWB As Workbook
Dim filepath As String
For Each newWs In Application.ActiveWorkbook.Worksheets
newWs.Copy
Set CurrentWB = ActiveWorkbook
ActiveWorkbook.ActiveSheet.UsedRange.Copy
Set TempWB = Application.Workbooks.Add(1)
With TempWB.Sheets(1).Range("A1")
.PasteSpecial xlPasteValues
.PasteSpecial xlPasteFormats
End With
Range("1:2").Delete
If Len(Dir(ThisWorkbook.Path & "\ProductSheets", vbDirectory)) = 0 Then
filepath = ThisWorkbook.Path
MkDir (filepath & "\ProductSheets")
End If
ActiveWorkbook.SaveAs Filename:=ThisWorkbook.Path & "\ProductSheets\" & newWs.Name & ".csv", _
FileFormat:=xlCSV, CreateBackup:=False
Application.ActiveWorkbook.Saved = True
Application.ActiveWorkbook.Close
Next
End Sub
The above code leaves all sheets open individually.
The below code is added to save all cells with formula which other wise would output as ref error
Set CurrentWB = ActiveWorkbook
ActiveWorkbook.ActiveSheet.UsedRange.Copy
Set TempWB = Application.Workbooks.Add(1)
With TempWB.Sheets(1).Range("A1")
.PasteSpecial xlPasteValues
.PasteSpecial xlPasteFormats
End With
The line newWs.Copy creates a copy of the existing sheet as a new workbook. As such you don't need some of the rest of your code. I'd do it as
Sub ExportAsCSVs()
Dim ws as worksheet
dim wb as workbook
for each ws in worksheets
ws.copy 'creates new workbook with one sheet
set wb = activeworkbook 'this is the workbook created above
wb.sheets(1).rows("1:2").delete
wb.saveas Filename:=ThisWorkbook.Path & "\ProductSheets\" & Ws.Name & ".csv", _
FileFormat:=xlCSV, CreateBackup:=False
wb.close false
next ws
End Sub
I have a spreadsheet with lots of tabs. I am wanting to copy each tab into its own file which I can do with the code below.
My problem is adding an instruction sheet aswell to each of the new workbooks. I have an instruction sheet in the original workbook.
Your help would be appreciated.
Sub Splitbook()
MyPath = ThisWorkbook.Path
For Each sht In ThisWorkbook.Sheets
sht.Copy
ActiveSheet.Cells.Copy
ActiveSheet.Cells.PasteSpecial Paste:=xlPasteValues
ActiveSheet.Cells.PasteSpecial Paste:=xlPasteFormats
ActiveWorkbook.SaveAs _
Filename:=MyPath & "\" & sht.Name & " SP Signoff.xlsx"
ActiveWorkbook.Close savechanges:=False
Next sht
End Sub
Sub Splitbook()
Dim wkb As Workbook
Dim wks As Worksheet, sht As Worksheet
Dim strPath As String
Set wkb = ThisWorkbook
Set wks = Sheets("Instructions")
strPath = wkb.Path
For Each sht In wkb.Sheets
If sht.Name <> "Instructions" Then
sht.Copy
With ActiveSheet
.Cells.Copy
.Cells.PasteSpecial Paste:=xlPasteValues
.Cells.PasteSpecial Paste:=xlPasteFormats
End With
wks.Copy Before:=ActiveWorkbook.Sheets(1)
ActiveWorkbook.SaveAs _
Filename:=MyPath & "\" & sht.Name & " SP Signoff.xlsx"
ActiveWorkbook.Close savechanges:=False
End If
Next
End Sub
I have a task to add workbook name into all worksheet's first column hence i need to have a macro and below is a draft of the same
Sub InsertWorkbookName()
Path = "C:\Users\mechee69\Download\"
Filename = Dir(Path & "*.xls")
Do While Filename <> ""
Workbooks.Open Filename:=Path & Filename, ReadOnly:=True
For Each Sheet In ActiveWorkbook.Sheets
Columns("A:A").Select
Selection.Insert Shift:=xlToRight, CopyOrigin:=xlFormatFromLeftOrAbove
Range("A1").Select
ActiveCell.SpecialCells(xlLastCell).Select
Application.Goto Range("A" & ActiveCell.Row), True
ActiveCell.Select
ActiveCell.FormulaR1C1 = _
"=RIGHT(LEFT(CELL(""filename""),FIND(""."",CELL(""filename""),FIND(""["",CELL(""filename""),1))-1),FIND(""."",CELL(""filename""),FIND(""["",CELL(""filename""),1))-FIND(""["",CELL(""filename""),1)-1)"
Application.Goto Range("A" & ActiveCell.Row), True
ActiveCell.Select
Selection.Copy
Range(Selection, Selection.End(xlUp)).Select
ActiveSheet.Paste
Application.CutCopyMode = False
Selection.Copy
Selection.PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks _
:=False, Transpose:=False
Application.CutCopyMode = False
ActiveWorkbook.Save
Next Sheet
Workbooks(Filename).Close
Filename = Dir()
Loop
End Sub
Try this
Sub WorkbookName()
Dim wbk As Workbook
Dim strFilename As String
Dim strPath As String
Dim wc As Worksheet
Dim lngLastR As Long
Dim lngSecurity as Long
lngSecurity = Application.AutomationSecurity
Application.AutomationSecurity = msoAutomationSecurityLow
strPath = "[Full Folder Path]"
strFilename = Dir(strPath & "*.xlsx")
Do While strFilename <> ""
Set wbk = Workbooks.Open(strPath & strFilename)
For Each ws In wbk.Worksheets
lngLastR = ws.Range("A" & Rows.Count).End(xlUp).Row
ws.Range("A:A").Insert Shift:=xlToRight
ws.Range("A1:A" & lngLastR).Value = wbk.Name
Next
wbk.Save
wbk.Close False
strFilename = Dir
Loop
Application.AutomationSecurity = lSecurity
MsgBox ("Done")
End Sub
As a quick run through of what this code does.
'Dir' goes through a folder on a criteria, the criteria in this case being ".xlsx" this is to make sure it only opens xlsx files.
'Do While' is a form of loop, this will repeat all code between the "Do While" and the "Loop" until the condition is no longer true.
Once deciding on the file it opens the workbook and remembers it as a variable, this is so I can reference it's name more easily.
I then find the last used row by starting at the bottom cell of row "A" and going up until there is data in a cell. There is a write up on this on stack overflow (Link: Error in finding last used cell in VBA)
I then insert a row to the left pushing the data to the right and set the value of all cells in row 'A' in the used ranged to the name of the workbook using the workbooks '.Name' function.
I then save and close the workbook before using the 'Dir' to the next file name ready to start the process again, this will repeat for all files and give you a message box saying "Done" once it has completed them all.
If you have any questions let me know
Edited to include a bypass for protected view
So this Macro will open Excel Files in a Folder with a specific format, then it prints the workbookname in A1 in every sheet of that file. It ignores the master, if its in the same folder.
Sub WorkbookName()
Dim wbk As Workbook
Dim Filename As String
Dim Path As String
Dim lastRow As Long
Dim lSecurity As Long
On Error Resume Next
Path = "C:\Users\User\Desktop\Files\" 'Folder of your Files
Filename = Dir(Path & "*.xlsx") 'Format of your files
Do While Filename <> "" And Filename <> "Master.xlsm" 'Dont Open MasterFile
Set wbk = Workbooks.Open(Path & Filename)
lSecurity = Application.AutomationSecurity
Application.AutomationSecurity = msoAutomationSecurityLow
For Each ws In wbk.Worksheets
With ws
.Range("A1").EntireColumn.Insert
lastRow = .Cells(Rows.Count, 2).End(xlUp).Row
.Range(Cells(1, 1), Cells(lastRow, 1)).Value = ActiveWorkbook.Name
End With
Application.AutomationSecurity = lSecurity
Next ws
wbk.Close True
Filename = Dir
Loop
End Sub
I have one large Excel workbook with multiple worksheets containing pivot tables linked to a big PowerPivot source. I want to save each worksheet separately into workbooks, only as values.
I have managed to do this on a workbook without pivot tables. But I get the following message with this project. I don't want to copy the embedded data for each save as it is crazy slow. Any hints or help?
Option Explicit
Sub JhSeparateSave()
Dim ws As Worksheet
Dim NewName As String
If MsgBox("Copy specific sheets to a new workbook" & vbCr & _
"New sheets will be pasted as values, named ranges removed" _
, vbYesNo, "NewCopy") = vbNo Then Exit Sub
' Input box to name new file
NewName = InputBox("Please Specify the name of your new workbook", "New Copy")
With Application
.ScreenUpdating = False
For Each ws In ThisWorkbook.Worksheets
If ws.Visible = xlSheetVisible Then
MsgBox ("Copy step 1")
ws.Copy
With ActiveWorkbook.Sheets(1).UsedRange
.Cells.Copy
.Cells.PasteSpecial xlPasteValues
.Cells(1).Select
End With
ActiveWorkbook.SaveAs ThisWorkbook.Path & "\" & NewName & "-" & ws.Name
ActiveWorkbook.Close
MsgBox ("Saved sheet: " & ws.Name)
End If
Next ws
End With
End Sub
See this example (TESTED AND TRIED).
Option Explicit
Sub JhSeparateSave()
Dim wbTemp As Workbook
Dim ws As Worksheet
Dim NewName As String
If MsgBox("Copy specific sheets to a new workbook" & vbCr & _
"New sheets will be pasted as values, named ranges removed" _
, vbYesNo, "NewCopy") = vbNo Then Exit Sub
'~~> Input box to name new file
NewName = InputBox("Please Specify the name of your new workbook", "New Copy")
With Application
.ScreenUpdating = False
For Each ws In ThisWorkbook.Worksheets
If ws.Visible = xlSheetVisible Then
MsgBox ("Copy step 1")
ws.Copy
ActiveWorkbook.SaveAs Filename:=ThisWorkbook.Path & "\" & NewName & ".csv", _
FileFormat:=xlCSV, CreateBackup:=False
ActiveWorkbook.Close savechanges:=False
Set wbTemp = Workbooks.Open(ThisWorkbook.Path & "\" & NewName & ".csv")
wbTemp.SaveAs Filename:=ThisWorkbook.Path & "\" & NewName & "-" & ws.Name, _
FileFormat:=xlOpenXMLWorkbook, CreateBackup:=False
wbTemp.Close savechanges:=False
Kill ThisWorkbook.Path & "\" & NewName & ".csv"
MsgBox ("Saved sheet: " & ws.Name)
End If
Next ws
End With
End Sub
what i eventually used:
Option Explicit
Sub Copier()
Dim ws As Worksheet
Dim wsNew As Worksheet
Dim NewName As String
Dim wsOriginalName As String
'On Error GoTo Errorcatch
If MsgBox("1. Copy to new sheet. 2. Change to values. 3. Move to new workbook" & vbCr & _
"New sheets will be pasted as values, named ranges removed" _
, vbYesNo, "NewCopy") = vbNo Then Exit Sub
' Input box to name new file
NewName = InputBox("Please Specify the month name of your new workbook", "New Copy")
With Application
.ScreenUpdating = False
.DisplayAlerts = False
'iterate through all worksheets
For Each ws In ThisWorkbook.Worksheets
'ignore hidden worksheets
If ws.Visible = xlSheetVisible Then
'copy sheet within original workbook
wsOriginalName = ws.Name
ws.Copy After:=Sheets("FAQ")
'switch to copied sheet
Set wsNew = ActiveSheet
'convert to values and format
With wsNew.UsedRange
.Copy
.PasteSpecial xlPasteValuesAndNumberFormats
.PasteSpecial xlPasteFormats
.Cells(1, 1).Select
End With
'save into new workbook
wsNew.Copy
ActiveWorkbook.SaveAs ThisWorkbook.Path & "\" & "MIS-FY2013-" & NewName & "-" & wsOriginalName
ActiveWorkbook.Close
'MsgBox ("going to try to delete: " & wsNew.Name)
'delete copied sheet
wsNew.Delete
End If
Next ws
End With
End Sub