I want to split workbook by worksheet name but if throws above error after splitting 5 sheets but i have 20 sheets in the workbook. I have used below code and the error happens at xWs.copy.
Please help me fix the error in the code. Thanks in advance.
Sub Splitbook()
'Updateby20140612
Dim xPath As String
xPath = Application.ActiveWorkbook.Path
Application.ScreenUpdating = False
Application.DisplayAlerts = False
For Each xWs In ThisWorkbook.Sheets
xWs.Copy
Application.ActiveWorkbook.SaveAs Filename:=xPath & "\" & xWs.Name & ".xlsx"
Application.ActiveWorkbook.Close False
Next
Application.DisplayAlerts = True
Application.ScreenUpdating = True
End Sub
I believe you have a hidden worksheet in the queue. In the following, I've stored the original Worksheet.Visible property value (XlSheetVisibility Enumeration), then made the worksheet visible and finally restored the original visiblility state. If it was already visible to begin with, there is no error.
I never recommend that you include a file extension in a Workbook.SaveAs operation. In fact, I recommend intentionally omitting it and allowing the FileFormat parameter and XlFileFormat Enumeration to supply the correct file extension.
Sub Splitbook()
Dim vis As Long, xPath As String, xWs As Worksheet
xPath = Application.ActiveWorkbook.Path
Application.ScreenUpdating = False
Application.DisplayAlerts = False
For Each xWs In ThisWorkbook.Sheets
vis = xWs.Visible
xWs.Visible = xlSheetVisible
xWs.Copy
Application.ActiveWorkbook.SaveAs Filename:=xPath & "\" & xWs.Name, _
FileFormat:=xlOpenXMLWorkbook
Application.ActiveWorkbook.Close False
xWs.Visible = vis
Next
Application.DisplayAlerts = True
Application.ScreenUpdating = True
End Sub
If you want to skip worksheets that are not visible, add a condition that does not perform the Copy, SaveAs operation if the xWs.Visible property is not xlSheetVisible.
If there is code in the worksheet code sheet (e.g. a Worksheet_Change event macro), it will be discarded without acknowledgement due to the Application.DisplayAlerts you have to False.
It looks like the workbook you are splitting gets activated, and because it contains macros it couldn't be saved as xlsx.
Try to add Application.EnableEvents = False before your For Each xWs In ThisWorkbook.Sheets and after the cycle Application.EnableEvents = True
Related
I'm trying to do something that seems simple, but keeps on causing me trouble.
Copying the active worksheet into a new workbook without formulas.
I've tried my luck with the following code:
Sub test()
ActiveSheet.Copy
With ActiveSheet.UsedRange
.Value = .Value
End With
End Sub
But that is quite unreliable, as it sometimes doesn't copy fields that clearly has a value.
I have cells that needs to have text that is both bold and normal and different sizes in the same damn cell.
The aforementioned method does not keep that formatting.
What I am currently doing looks like this:
Sub EksporterExcel()
Dim ws As Worksheet
Dim wb As Workbook
Dim tid As String
Set ws = Sheets(ActiveSheet.Name)
tid = Format(CStr(Now), "hh.mm.ss")
Application.DisplayAlerts = False
Application.ScreenUpdating = False
ws.Copy
Set wb = Workbooks(ActiveWorkbook.Name)
ws.UsedRange.Copy
wb.Worksheets(1).Range("A1").PasteSpecial Paste:=xlPasteValuesAndNumberFormats
Application.CutCopyMode = False
ActiveWorkbook.SaveAs _
FileFormat:=51, _
Filename:=Application.ThisWorkbook.Path & "\Udfyldte Indleveringsplaner\Excel\" & Date & "\" & ActiveSheet.Name & " Kl. " & tid & ".xlsx"
ActiveWorkbook.Close
Application.DisplayAlerts = True
Application.ScreenUpdating = True
End Sub
And that works.
It is however slow. Very, very slow. I'm assuming that this has to do with copying the sheet first and the going back to copy the cell values, so I'd like a way to avoid that.
This way also doesn't keep the formatting in the single cells that has multiple formatting options. That's low priority however.
I would love to know if there's a more efficient way to do this.
Below is an example of the result when using the first snippet of code, or the code in the answer by jkpieterse.
The original sheet before being copied.
The copied sheet
Some of the data is clearly lost after being copied
What about this version (also tidied up some of your code):
Sub EksporterExcel()
Dim tid As String
tid = Format(CStr(Now), "hh.mm.ss")
Application.DisplayAlerts = False
Application.ScreenUpdating = False
ActiveSheet.Copy
ActiveSheet.UsedRange.Value2 = ActiveSheet.UsedRange.Value2
ActiveWorkbook.SaveAs _
FileFormat:=51, _
Filename:=Application.ThisWorkbook.Path & "\Udfyldte Indleveringsplaner\Excel\" & Date & "\" & ActiveSheet.Name & " Kl. " & tid & ".xlsx"
'Assume it is the active workbook you wanted to close...
ActiveWorkbook.Close
Application.DisplayAlerts = True
Application.ScreenUpdating = True
End Sub
Currently i'm trying to consolidate the information from 3000 different xls sheets into one file.
The master file looks like this
http://i.imgur.com/lQWxQxO.png
All the other excels are contained in 1 folder like this. They are only 1 sheet each.
http://i.imgur.com/VxmaLCf.png
and lastly would be that the information inside the files are like this
http:// i.imgur.com/w3erGgN.png
I'm trying to count the number of "pos", "neg" and "neu" inside the files and consolidate on the master sheet and the current way i'm doing is to manually input countif codes while leaving the document open. Is there any other way to make it faster? I've tried sumproduct but it never works. it only returns 0 as i think it might be the wildcard problem.
I think the following code could be of use to me but I'm not sure how to code it such that it works accordingly.
Sub RunCodeOnAllXLSFiles()
Dim lCount As Long
Dim wbResults As Workbook
Dim wbCodeBook As Workbook
Application.ScreenUpdating = False
Application.DisplayAlerts = False
Application.EnableEvents = False
On Error Resume Next
Set wbCodeBook = ThisWorkbook
With Application.FileSearch
.NewSearch
'Change path to suit
.LookIn = "C:\MyDocuments\TestResults"
.FileType = msoFileTypeExcelWorkbooks
'Optional filter with wildcard
'.Filename = "Book*.xls"
If .Execute > 0 Then 'Workbooks in folder
For lCount = 1 To .FoundFiles.Count 'Loop through all
'Open Workbook x and Set a Workbook variable to it
Set wbResults = Workbooks.Open(Filename:=.FoundFiles(lCount), UpdateLinks:=0)
'DO YOUR CODE HERE
wbResults.Close SaveChanges:=False
Next lCount
End If
End With
On Error GoTo 0
Application.ScreenUpdating = True
Application.DisplayAlerts = True
Application.EnableEvents = True
End Sub
Please help.
Sub Merge()
Path = "C:\path to the folder\"
Filename = Dir(Path & "*.xls")
Do While Filename <> ""
Workbooks.Open Filename:=Path & Filename, ReadOnly:=True
For Each Sheet In ActiveWorkbook.Sheets
Sheet.Copy After:=ThisWorkbook.Sheets(1)
Next Sheet
Workbooks(Filename).Close
Filename = Dir()
Loop
End Sub
Found here: http://www.extendoffice.com/documents/excel/456-combine-multiple-workbooks.html
I need help saving specific tabs from excel workbooks as 1) csv files, and 2) files named after the file from which they originate.
So far I have this which works in taking out the right tab from a single workbook and saving it as a .csv file.
Sub Sheet_SaveAs()
Dim wb As Workbook
Sheets("SheetName").Copy
Set wb = ActiveWorkbook
With wb
.SaveAs ThisWorkbook.Path & "\SheetName.csv"
'.Close False
End With
End Sub
How do I rename "SheetName" so that the file saves as, for example, Workbook1SheetName, Workbook2SheetName etc.?
I want to loop this function through a folder of many, many excel files, so unique names are necessary for the new .csv files.
I found this online which shows how to use a VBA loop, http://www.ozgrid.com/VBA/loop-through.htm. In theory it should work with my code above as long as each .csv file can have a unique name. Correct me if I am wrong.
Thanks for the help.
As you've discovered, when you copy a worksheet with no destination you end up with a new workbook populated by the copy of worksheet. The new workbook becomes the ActiveWorkbook property in the VBA environment. To save the workbook as a CSV file you need to retrieve the Worksheet .Name property of the sole worksheet in that new workbook.
Sub All_Sheet_SaveAs_CSV()
Dim w As Long, wb As Workbook
Dim fp As String, fn As String
On Error GoTo bm_Safe_Exit
'Application.ScreenUpdating = False 'stop screen flashing
Application.DisplayAlerts = False 'stop confirmation alerts
'start with a reference to ThisWorkbook
With ThisWorkbook
fp = .Path
'cycle through each of the worksheets
For w = 1 To Worksheets.Count
With Worksheets(w)
.Copy
'the ActiveWorkbook is now the new workbook populated with a copy of the current worksheet
With ActiveWorkbook
fn = .Worksheets(1).Name
.SaveAs Filename:=fp & Chr(92) & fn, FileFormat:=xlCSV
.Close savechanges:=False '<~~ already saved in line above
End With
End With
Next w
End With
bm_Safe_Exit:
Application.DisplayAlerts = True
Application.ScreenUpdating = True
End Sub
Note that turning .DisplayAlerts will turn off the warnings that you would normally receive. While this is helpful with the CSV file format, it also will not warn you if you attempt to overwrite a file.
The Workbook.SaveAs method with a file format parameter of xlCSV will supply the correct file extension. There is no need to include it as part of the filename.
If a limited number of specific worksheets are intended to receive the export-to-CSV procedure, then an array of worksheet names could be cycled through rather than the worksheet index position.
Sub Specific_Sheets_SaveAs_CSV()
Dim v As Long, vWSs As Variant
Dim fp As String, fn As String
On Error GoTo bm_Safe_Exit
'Application.ScreenUpdating = False 'stop screen flashing
Application.DisplayAlerts = False 'stop confirmation alerts
vWSs = Array("Sheet1", "Sheet3", "Sheet5")
'start with a reference to ThisWorkbook
With ThisWorkbook
fp = .Path
'cycle through each of the worksheets
For v = LBound(vWSs) To UBound(vWSs)
With Worksheets(vWSs(v))
.Copy
'the ActiveWorkbook is now the new workbook populated with a copy of the current worksheet
With ActiveWorkbook
fn = .Worksheets(1).Name
.SaveAs Filename:=fp & Chr(92) & fn, FileFormat:=xlCSV
.Close savechanges:=False '<~~ already saved in line above
End With
End With
Next v
End With
bm_Safe_Exit:
Application.DisplayAlerts = True
Application.ScreenUpdating = True
End Sub
I have a macros that generates a number of workbooks. I would like the macros, at the start of the run, to check if the file contains 2 spreadsheets, and delete them if they exist.
The code I tried was:
If Sheet.Name = "ID Sheet" Then
Application.DisplayAlerts = False
Sheet.Delete
Application.DisplayAlerts = True
End If
If Sheet.Name = "Summary" Then
Application.DisplayAlerts = False
Sheet.Delete
Application.DisplayAlerts = True
End If
This code is returning an error:
run time error #424, object required.
I probably have the wrong formatting, but if there is an easier way to do this, it would be very useful.
Consider:
Sub SheetKiller()
Dim s As Worksheet, t As String
Dim i As Long, K As Long
K = Sheets.Count
For i = K To 1 Step -1
t = Sheets(i).Name
If t = "ID Sheet" Or t = "Summary" Then
Application.DisplayAlerts = False
Sheets(i).Delete
Application.DisplayAlerts = True
End If
Next i
End Sub
NOTE:
Because we are deleting, we run the loop backwards.
Try this code:
For Each aSheet In Worksheets
Select Case aSheet.Name
Case "ID Sheet", "Summary"
Application.DisplayAlerts = False
aSheet.Delete
Application.DisplayAlerts = True
End Select
Next aSheet
You could use On Error Resume Next then there is no need to loop through all the sheets in the workbook.
With On Error Resume Next the errors are not propagated, but are suppressed instead. So here when the sheets does't exist or when for any reason can't be deleted, nothing happens. It is like when you would say : delete this sheets, and if it fails I don't care. Excel is supposed to find the sheet, you will not do any searching.
Note: When the workbook would contain only those two sheets, then only the first sheet will be deleted.
Dim book
Dim sht as Worksheet
set book= Workbooks("SomeBook.xlsx")
On Error Resume Next
Application.DisplayAlerts=False
Set sht = book.Worksheets("ID Sheet")
sht.Delete
Set sht = book.Worksheets("Summary")
sht.Delete
Application.DisplayAlerts=True
On Error GoTo 0
Worksheets("Sheet1").Delete
Worksheets("Sheet2").Delete
try this within your if statements:
Application.DisplayAlerts = False
Worksheets(“Sheetname”).Delete
Application.DisplayAlerts = True
i've searched multiple forums to see if i can discover why a peice of code isnt working but havent found an answer yet.
My VBA isnt great and i inherited this section of code from a predecessor.
This part of the code saves each indivisual worksheet as a new workbook by using the worksheet names.
Dim NewBook As Workbook, OldBook As Workbook, sh As Worksheet
Application.ScreenUpdating = False
Application.Calculation = xlCalculationManual
Application.DisplayAlerts = False
Set OldBook = ThisWorkbook
For Each sh In OldBook.Worksheets
If sh.Visible = True Then
sh.Copy
ActiveWorkbook.SaveAs Filename:="Pathway" & "\" & sh.Name, FileFormat:=xlExcel8
ActiveWorkbook.Close
End If
Next
Application.ScreenUpdating = True
Application.Calculation = xlCalculationAutomatic
ActiveWorkbook.Close False
This works fine and will create the sheets for me but I now need to add to the file name by using the same cell value from each worksheet (B1) so i tried adding to the code.
ActiveWorkbook.SaveAs Filename:="Pathway" & "\" & sh.Range("B1").Value & sh.Name, FileFormat:=xlExcel8
However doing so results in a "Run-time error '1004': There is no active Protected View Window" but i'm not too sure why that would be?
Any help here would be much appreciated.
This is likely due to your path not being a string accepted by Windows as file name. As the problem appears when you add B1 to the path, this seems to be the source of your problem. Check if cell B1 contains any characters not allowed in file names.