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 & ".xlsx"
ActiveWorkbook.Close savechanges:=True
Next sht
End Sub
It is giving an error
Runtime error 1004
Copy method of worksheet class failed
How can i remove this error?
Test code using objects to handle the copy properly:
Sub Splitbook()
Dim MyPath As String
Dim ShT As Worksheet
Dim NewWB As Workbook
Dim NewSHT As Worksheet
MyPath = ThisWorkbook.Path
For Each ShT In ThisWorkbook.Sheets
ShT.Copy
Set NewWB = ActiveWorkbook
With NewWB
With .Sheets(1)
With .Cells
.Copy
.PasteSpecial Paste:=xlPasteValues
.PasteSpecial Paste:=xlPasteFormats
End With '.Cells
End With '.Sheets(1)
.SaveAs FileName:=MyPath & "\" & ShT.Name & ".xlsx"
.Close savechanges:=True
End With 'NewWB
Next ShT
End Sub
Sub Splitbook()
MyPath = ThisWorkbook.Path
For Each sht In ThisWorkbook.Sheets
sht.usedrange.copy
set wb= workbooks.add
wb.sheets(1).Paste
application.cutcopymode=false
wb.saveas(filename:=MyPath & "_" & sht.Name & ".xlsx",xlopenXMLworkbook)
wb.close
Next sht
End Sub
try this subroutine this might work. I havent tested the code. Please forgive me if there are any bugs.
Related
I have a script that does a vlookup for each sheet in workbook and then splits each worksheet into its own file. I have the below script, but it is not working. The vlookup portion is working fine, but I am having issues with the split. It doesn't fail and give me an error, it just doesn't do anything.
Sub Splitbook()
MyPath = "***Folder Location***"
For Each sht In Workbooks("PO135 Division 1.xlsx").Worksheets
sht.Copy
ActiveSheet.Cells.Copy
ActiveSheet.Cells.PasteSpecial Paste:=xlPasteValues
ActiveSheet.Cells.PasteSpecial Paste:=xlPasteFormats
ActiveWorkbook.SaveAs _
Filename:=MyPath & "\" & sht.Name & ".xlsx"
ActiveWorkbook.Close savechanges:=False
Next sht
End Sub
I need to split the files and then save them in a distinct folder("Folder Location")--this is just a placeholder for the time being, it would be updated prior to running the script--
Any thoughts? Appreciate the help!
Put this in a regular module:
Sub NewWb()
Dim ws As Worksheet
Dim wbActive As Workbook
Dim wbNew As Workbook
Dim x As Single
Application.ScreenUpdating = False
Set wbActive = ActiveWorkbook
For Each ws In wbActive.Worksheets
Set wbNew = Workbooks.Add
ws.Copy Before:=wbNew.Sheets(1)
abc = "C:\Files\" & ws.Name & ".xlsx"
Application.DisplayAlerts = False
wbNew.Sheets("Sheet1").Delete
Application.DisplayAlerts = True
wbNew.SaveAs Filename:=abc
wbNew.Close Saved = True
Next ws
Set ws = Nothing
Set wbActive = Nothing
Set wbNew = Nothing
Application.ScreenUpdating = True
End Sub
This is as far as I got with it however it is now only copying the active.sheet multiple times rather than cycling through.
The idea of what I was trying to achieve was for a macro to run and covert every worksheet as a .csv. The filename of that .csv would be the worksheet name which is decided by another macro than runs earlier in the flow.
Any ideas on how to circle through, as I said before. I am fairly new to code hence why I am asking.
Sub Export_Sub_Xpath()
'
' Export_Sub_Xpath Macro
'
Dim i As Integer
Dim WS_Count As Integer
Dim ws As Worksheet
WS_Count = ActiveWorkbook.Worksheets.Count
For i = 1 To WS_Count
Set ws = ThisWorkbook.Worksheets(i)
PathName = "" & ActiveWorkbook.Path & "\" & ws.Name & ".csv"
Columns("A:B").Select
Range("B3000").Activate
Selection.Copy
PathName = "" & ActiveWorkbook.Path & "\" & ws.Name & ".csv"
Workbooks.Add
ActiveSheet.Paste
Application.CutCopyMode = False
'ActiveWorkbook.SaveAs PathName = "" & ActiveWorkbook.Path & "\" & ws.Name & ".csv"
ActiveWorkbook.SaveAs Filename:=PathName, _
FileFormat:=xlCSV, CreateBackup:=False
ActiveWorkbook.Close
Next i
End Sub
You forgot to activate each sheet before copying and saving. Try this:
Sub Export_Sub_Xpath() ' ' Export_Sub_Xpath Macro '
Dim i As Integer
Dim WS_Count As Integer
Dim ws As Worksheet
WS_Count = ThisWorkbook.Worksheets.Count
For i = 1 To WS_Count
Set ws = ThisWorkbook.Worksheets(i)
PathName = "" & ThisWorkbook.Path & "\" & ws.Name & ".csv"
ThisWorkbook.Worksheets(i).Activate ' You forgeot to Activate Each Sheet before saving
Columns("A:B").Select
Range("B3000").Activate
Selection.Copy
Workbooks.Add
ActiveSheet.Paste
Application.CutCopyMode = False
ActiveWorkbook.SaveAs Filename:=PathName, _
FileFormat:=xlCSV, CreateBackup:=False
ActiveWorkbook.Close
Next i
End Sub
I've got this Macro working beautifully, but every now and again it will save the exported sheets into the last folder I was working in, and not the specific folder I want them in. How do I specify the folder they should go into?
Sub asdf()
Dim ws As Worksheet, newWb As Workbook
Application.ScreenUpdating = False
For Each ws In Sheets(Array("sheet1", "sheet2", "sheet3"))
ws.Copy
Set newWb = ActiveWorkbook
With newWb
.SaveAs ws.Name & ".csv", xlCSVWindows
.Close (False)
End With
Next ws
Application.ScreenUpdating = True
End Sub
You need to specify the location you want it saved to in the code.
Try this.
.SaveAs FileName:="C:\OutputFilepath\" & ws.Name & ".csv", FileFormat:=xlCSV, CreateBackup:=False
Replace this line
.SaveAs ws.Name & ".csv", xlCSVWindows
With
.SaveAs "D:\MyFolder\" & ws.Name & ".csv", xlCSVWindows
Change the "D:\MyFolder\" to your desired path.
Add a string type var that contains the full path to the folder. In the following example, I'll use the temp directory.
Sub asdf()
Dim ws As Worksheet, newWb As Workbook, fp as string
fp = environ("TEMP") & Chr(92)
'could be something like
'fp = environ("USER") & "\desktop\"
Application.ScreenUpdating = False
For Each ws In Sheets(Array("sheet1", "sheet2", "sheet3"))
ws.Copy
Set newWb = ActiveWorkbook
With newWb
.SaveAs fp & ws.Name, xlCSVWindows 'add the path, let saveas add the extension
.Close savechanges:=False
End With
Next ws
Application.ScreenUpdating = True
End Sub
I am using this code to copy every sheet in a workbook to a new one and it works fine but it reverses the order of the sheets, would there be anyway to keep it from doing this?
Sub copy()
'copies all the sheets of the open workbook to a new one
Dim thisWb As Workbook, wbTemp As Workbook
Dim ws As Worksheet
On Error GoTo Whoa
Application.DisplayAlerts = False
Set thisWb = ThisWorkbook
Set wbTemp = Workbooks.Add
On Error Resume Next
For Each ws In wbTemp.Worksheets
ws.Delete
Next
On Error GoTo 0
For Each ws In thisWb.Sheets
ws.copy After:=wbTemp.Sheets(1)
Next
wbTemp.Sheets(1).Delete
'save vba code here
Application.Dialogs(xlDialogSaveAs).Show Range("CA1").Text & "- (Submittal) " & Format(Date, "mm-dd-yy") & "_" & Format(Time, "hhmm") & ".xlsx"
LetsContinue:
Application.DisplayAlerts = True
Exit Sub
Whoa:
MsgBox Err.Description
Resume LetsContinue
End Sub
I'm copying all the sheets so i can save it as a different file extension and this was the only way i found that worked.
Workbook before it copies
Workbook after it copies
From Scott Craner's comment, which OP replied to indicating it worked:
Change
ws.copy After:=wbTemp.Sheets(1)
to:
ws.copy After:=wbTemp.Sheets(wbTemp.Worksheets.Count)
If you only want to change the file format
(I'm copying all the sheets so i can save it as a different file extension and this was the only way i found that worked.)
Then you can try this code:
Sub Test()
fn = Range("CA1").Text & "- (Submittal) " & Format(Now, "mm-dd-yy_hhmm")
fileSaveName = Application.GetSaveAsFilename(InitialFileName:=fn, fileFilter:="Excel Workbook (*.xlsx), *.xlsx")
If fileSaveName <> False Then
Application.DisplayAlerts = False
ActiveWorkbook.SaveAs fileSaveName, xlOpenXMLWorkbook
Application.DisplayAlerts = True
End If
End Sub
I've got this working, except I need the resulting files to be specifically a 'windows comma separated CSV' file. Any ideas how to specify this?
Sub asdf()
Dim ws As Worksheet, newWb As Workbook
Application.ScreenUpdating = False
For Each ws In Sheets(Array("sheet1", "sheet2"))
ws.Copy
Set newWb = ActiveWorkbook
With newWb
.SaveAs ws.Name & ".csv", xlCSV
.Close (False)
End With
Next ws
Application.ScreenUpdating = True
End Sub
It should be as easy as specifying the FileFormat as CSVWindows
.SaveAs ws.Name & ".csv", xlCSVWindows