I have a macro in a workbook that saves selected sheets in a workbook as separate csv files. I thought this was working fine but I now seem to be getting the error message below, I'm not sure if I've inadvertently changed something, as I was trying to write a separate macro to run this one from another workbook.
Error message:
Run time error '1004'
Cannot access read-only document ' Activity.csv'
Public Sub SaveWorksheetsAsCsv3()
'save workbook before continuing
ActiveWorkbook.Save
Application.DisplayAlerts = False
'save each sheet as csv
Dim WB As Workbook
Dim WS As Worksheet
Dim FolderPath As String
Dim FileName As String
'folder path for saving
FolderPath = Range("B3").Value
'loop through all sheets
For Each WS In Worksheets
'ignore these sheets
If WS.Name <> "Control" And WS.Name <> "Summary" Then
'copy current sheet
WS.Copy
Set WB = ActiveWorkbook
'save as csv file
FileName = WS.Name
WB.SaveAs FileName:=FolderPath & "\" & FileName, FileFormat:=xlCSV, CreateBackup:=False
Application.DisplayAlerts = True
WB.Close
Application.DisplayAlerts = False
End If
Next WS
End Sub
Related
This Macro I have continues to merge the files from my folder into the current open workbook. I am trying to open a new workbook and have it merge into the new open workbook. I am not sure where I need to activate the newly opened/ added workbook in order for the merge to take place in that file.
Sub MergeWorkbooks()
Application.DisplayAlerts = False
Workbooks.Add
ActiveWorkbook.SaveAs FileName:="C:\ ....\Merged Files.xlsx"
Dim FolderPath As String
Dim Filename As String
Dim Sheet As Worksheet
Application.ScreenUpdating = False
FolderPath = "<Folder destination>"
Filename = Dir(FolderPath & "*.xls*")
workbooks("Merged Files.xlsx").Activate
Do While Filename <> ""
Workbooks.Open Filename:=FolderPath & Filename, ReadOnly:=True
For Each Sheet In ActiveWorkbook.Sheets
Sheet.Copy After:=ThisWorkbook.Sheets(1)
Next Sheet
Workbooks(Filename).Close
Filename = Dir()
Loop
Application.ScreenUpdating = True
End Sub
Since Workbooks.Add and Workbooks.Open return a reference to the newly added or opened workbook, use two Workbook variables:
Dim mergedWb As Workbook
Set mergedWb = Workbooks.Add()
mergedWb.SaveAs FileName:="C:\ ....\Merged Files.xlsx"
...
Do While Filename <> ""
Dim wb As Workbook
Set wb = Workbooks.Open(Filename:=FolderPath & Filename, ReadOnly:=True)
For Each Sheet In wb.Sheets
Sheet.Copy After:=mergedWb.Sheets(1)
Next Sheet
wb.Close
Filename = Dir()
Loop
Apologies for any bad coding or ignorance I'm a very basic user of VBA.
I have a WorkbookA that has X number of sheets which can change daily. I cobbled together code which will copy the active sheet from WorkbookA to WorkbookB, define a save directory and name, save, and close WorkbookB.
I want to loop through all sheets in WorkbookA starting from the active sheet to the last sheet. How can i go about doing this?
Public Sub CopySheetToNewWorkbook()
ActiveSheet.Copy
Name = ActiveSheet.Name & ".xls"
Path = "MyPath\"
ActiveWorkbook.SaveAs (Path & Name)
ActiveWorkbook.Close
End Sub
Copy Sheets to Separate Workbooks
Use with caution because files will be overwritten without asking.
Option Explicit
Sub CopySheetToNewWorkbook()
Const MyPath As String = "MyPath" ' Sub Folder Name of This Workbook's Path
Dim ws As Worksheet ' First Worksheet
Dim i As Long ' Sheets Counter
Dim SavePath As String ' Save Path
Dim SaveFullName As String ' Save Full Name
With ThisWorkbook
Set ws = .ActiveSheet
SavePath = .Path & Application.PathSeparator & MyPath _
& Application.PathSeparator
Application.ScreenUpdating = False
For i = ws.Index To .Sheets.Count
With .Sheets(i)
SaveFullName = SavePath & .Name & ".xls"
.Copy
End With
GoSub SaveAndClose
Next i
Application.ScreenUpdating = True
End With
MsgBox "Copied sheets to new workbooks.", vbInformation, _
"New Workbooks Saved and Closed"
GoTo exitProcedure
' Save and close new workbook.
SaveAndClose:
On Error GoTo NewWorkbookError ' e.g. if workbook with same name is open.
With ActiveWorkbook
' Note: The two Application.DisplayAlerts lines prevent Excel
' complaining about e.g.:
' Overwrite if file exists.
' Save if data outside of FileFormat (Compatibility Checker).
Application.DisplayAlerts = False
.SaveAs SaveFullName, FileFormat:=xlExcel8
Application.DisplayAlerts = True
.Close False ' Close but do not save.
End With
On Error GoTo 0
Return
NewWorkbookError:
ActiveWorkbook.Close False ' Close but do not save.
MsgBox Err.Description, vbExclamation, "New Workbook Closed and Not Saved"
Resume exitProcedure
exitProcedure:
End Sub
Copy Sheets to Single Workbook
I developed this code first assuming (misreading the post) that the ActiveSheet had some kind of date in its name.
Use with caution because files will be overwritten without asking.
Sub CopySheetsToNewWorkbook()
Const MyPath As String = "MyPath" ' Sub Folder Name of This Workbook's Path
Dim ws As Worksheet ' First Worksheet
Dim SheetsGroup() As String ' Sheets Group Array
Dim SheetsDiff As Long ' Sheets Difference
Dim i As Long ' Sheets Array Elements (Columns) Counter
Dim SavePath As String ' Save Path
Dim SaveName As String ' Save Name
' Copy sheets from this workbook to new workbook.
With ThisWorkbook
' Define First Worksheet, Save Name and Save Path.
Set ws = .ActiveSheet
SaveName = ws.Name & ".xls"
SavePath = .Path & Application.PathSeparator & MyPath _
& Application.PathSeparator & SaveName
' Write sheet names to Sheets Group Array.
ReDim SheetsGroup(.Sheets.Count - ws.Index)
SheetsDiff = .Sheets.Count - ws.Index
For i = 0 To SheetsDiff
SheetsGroup(i) = .Worksheets(i + SheetsDiff - 1).Name
Next i
' Copy sheets from Sheets Group Array to new workbook (ActiveWorkbook).
.Sheets(SheetsGroup).Copy
End With
' Save and close New Workbook.
On Error GoTo NewWorkbookError ' e.g. if workbook with same name is open.
With ActiveWorkbook
' Note: The two Application.DisplayAlerts lines prevent Excel
' from complaining about e.g.:
' Overwrite if file exists.
' Save if data outside of FileFormat (Compatibility Checker).
Application.DisplayAlerts = False
.SaveAs SavePath, FileFormat:=xlExcel8
Application.DisplayAlerts = True
.Close False ' Close but do not save.
End With
On Error GoTo 0
MsgBox "Copied sheets to new workbook.", vbInformation, _
"New Workbook Saved and Closed"
GoTo exitProcedure
NewWorkbookError:
ActiveWorkbook.Close False ' Close but do not save.
MsgBox Err.Description, vbExclamation, "New Workbook Closed and Not Saved"
Resume exitProcedure
exitProcedure:
End Sub
Close Workbooks
A few times I had over ten workbooks open while developing the previous code, so I wrote this little time saver.
Use it with caution because workbooks will be closed without saving changes.
''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''
' Purpose: Closes all workbooks except this one (ThisWorkbook). '
' Remarks: Be careful because all the changes on those other workbooks '
' will be lost. '
''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''
Sub closeWorkbooks()
Dim wb As Workbook
Application.ScreenUpdating = False
For Each wb In Workbooks
If Not wb Is ThisWorkbook Then wb.Close False
Next wb
Application.ScreenUpdating = True
End Sub
''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''
I want to copy multiple sheets from one workbook(4 out of 14) but i'm starting with one("Data"). I want to rename the workbook based on a cell in the first workbook. with this code I get an "run-time error '1004' Excel cannot access the file 'C:\3B4DD....
my code so far:
Sub Newyeartest()
sheetstocopy = "data"
Worksheets(sheetstocopy).Copy
Dim FName As String
Dim FPath As String
FPath = "C:"
FName = Sheets("data").Range("A1") & ".xlsm"
ThisWorkbook.SaveAs Filename:=FPath & "\" & FName, FileFormat:=52
End sub
If I delete the "Fileformat:=52" It seems to go better but I get a text that this file must be saved as an macro enabled file. But I would guess that "Xlsm" is macro enabled?
Instead of copying worksheets, the better way is to copy the workbook with all the worksheets and then delete the ones that are not needed.
The code saves the workbook first, using the path of the current workbook;
Then it starts checking every worksheet, making sure that the name is not "data";
If the name is not "data" and there are more than 1 worksheets left, it deletes the worksheet;
The Application.DisplayAlerts = False is needed, in order to remove the msgbox for confirmation of the deletion of the worksheet. Then the Alerts are back set to True;
If the name is not "data" and this is the last worksheet, it gives a MsgBox "Last worksheet cannot be deleted!", as far as a workbook should always have at least 1 worksheet, by design;
Sub NewTest()
ThisWorkbook.SaveAs ThisWorkbook.Path & "\new.xlsm"
Dim sheetToCopy As String: sheetToCopy = "data"
Dim wks As Worksheet
For Each wks In ThisWorkbook.Worksheets
If wks.Name <> sheetToCopy Then
If ThisWorkbook.Worksheets.Count > 1 Then
Application.DisplayAlerts = False
ThisWorkbook.Worksheets(wks.Name).Delete
Application.DisplayAlerts = True
Else
MsgBox "Last worksheet cannot be deleted!"
End If
End If
Next wks
End Sub
This should do the trick:
Option Explicit
Sub Newyeartest()
Dim wb As Workbook
Dim SheetNames As Variant, Key As Variant
Dim FName As String, FPath As String
Application.ScreenUpdating = False
SheetNames = Array("data", "data2", "data3", "data4") 'store the sheet names you want to copy
Set wb = Workbooks.Add 'set a workbook variable which will create a new workbook
'loop through the sheets you previously stored to copy them
For Each Key In SheetNames
ThisWorkbook.Sheets(Key).Copy After:=wb.Sheets(wb.Sheets.Count)
Next Key
'delete the first sheet on the new created workbook
Application.DisplayAlerts = False
wb.Sheets(1).Delete
FPath = "C:\Test"
FName = ThisWorkbook.Sheets("data").Range("A1") & ".xlsm"
wb.SaveAs Filename:=FPath & "\" & FName, FileFormat:=52
With Application
.ScreenUpdating = True
.DisplayAlerts = True
End With
End Sub
You cannot save directly to C:\ so you need to create a folder and the code will work.
I have a question, I would like to save all my worksheets to seperate csv files and after it is finished the original excel file should be used. I've found some questions related to this on stackoverflow BUT I cannot combine them to make it work :(
Here is what I have at the moment which works:
Sub SaveSheetsAsCsv()
Dim ws As Worksheet
Application.DisplayAlerts = False
For Each ws In ActiveWorkbook.Worksheets
ws.SaveAs ActiveWorkbook.Path & "\" & ws.Name & ".csv", xlCSV, Local:=True
Next
Application.DisplayAlerts = True
End Sub
The result, I have all my worksheets saved to the same folder BUT then my workbook is named as my last worksheet and if I want to close it says I have to save it ... but instead I would like to have my original excel file active.
Any idea how can I do that?
I've tried to implement this: Keep the same excel but I always get an error :(
Any advice and help would be appreciated.
The adjustment below copies the sheet to a new book, saves it as CSV and closes.
Sub SaveSheetsAsCsv()
Dim wb As Workbook
Dim ws As Worksheet
Set wb = ThisWorkbook
Application.DisplayAlerts = False
For Each ws In ActiveWorkbook.Worksheets
ws.Copy
ActiveWorkbook.SaveAs wb.Path & "\" & ws.Name & ".csv", xlCSV, Local:=True
ActiveWorkbook.Close
Next
Application.DisplayAlerts = True
End Sub
I'm trying to do the following:
Export/Copy particular sheets in the workbook (any sheet name that contains "Upload") to a particular file directory.
I don't want these worksheet names to change nor the workbook name to change.
The file-name is consistent for each worksheet, so it would be okay to replace the files in the directory whenever I run the macro. It is okay to have a dialog box that asks if I'm sure I want to replace each of the files.
I don't want the newly created CSVs or any other file to open.
Sub SheetsToCSV()
'Jerry Beaucaire (1/25/2010), updated (8/15/2015)
'Save each sheet to an individual CSV file
Dim ws As Worksheet, fPATH As String
Application.ScreenUpdating = False 'speed up macro
Application.DisplayAlerts = False 'automatically overwrite old files
fPATH = "C:\2015\CSV\" 'path to save into, remember the final \ in this string
For Each ws In Worksheets
ws.Copy
ActiveWorkbook.SaveAs Filename:=fPATH & ActiveSheet.Name & ".csv", FileFormat:=xlCSV, CreateBackup:=False
ActiveWorkbook.Close
Next ws
Application.ScreenUpdating = True
End Sub
You just need to add a simple loop through all worksheets and test the name.
Try this:-
Sub COPYSelectedSheetsToCSV()
Dim ws As Worksheet
'In case something goes wrong
On Error GoTo COPYSelectedSheetsToCSVZ
'Loop through all worksheets
For Each ws In ActiveWorkbook.Sheets
'Does the name contain "Upload"
If InStr(1, ws.Name, "Upload") > 0 Then
'Make the worksheet active
ws.Select
'Save it to CSV
ActiveWorkbook.SaveAs Filename:="/Users/reginaho/Desktop/Upload/" & ws.Name & ".csv", _
FileFormat:=xlCSV, CreateBackup:=False
End If
Next
COPYSelectedSheetsToCSVX:
'Clean up the memory usage
Set ws = Nothing
Exit Sub
COPYSelectedSheetsToCSVZ:
MsgBox Err.Number & " - " & Err.Description
Resume COPYSelectedSheetsToCSVX
End Sub