I am trying to create a copy of my workbook when saving but when I create that copy, lock all cells so they can't be changed.
Here is what I have...
Private Sub Workbook_BeforeSave(ByVal SaveAsUI As Boolean, Cancel As Boolean)
Dim FName As String
Dim FPath As String
Dim NewBook As Workbook
FPath = ThisWorkbook.Path & "\" '& FName
FName = "Saved File" & Format(Date, "YYMMDD") & ".xlsx"
Set NewBook = Workbooks.Add
Application.DisplayAlerts = False
ThisWorkbook.Sheets.Copy
ActiveWorkbook.SaveAs Filename:=FPath & FName, FileFormat:=51
ActiveWorkbook.Close
Application.DisplayAlerts = True
'NewBook.SaveAs Filename:=FPath & FName, FileFormat:=51
Application.DisplayAlerts = False
NewBook.Close
Application.DisplayAlerts = True
End Sub
Any help would be much appreciated.
Many thanks in advance
In your case, you can use usedrange.locked to lock the entire used range of the new workbook. However this does not prevent editing until the workbook is protected, so best to do that as well with worksheet.protect. Full code:
Private Sub Workbook_BeforeSave(ByVal SaveAsUI As Boolean, Cancel As Boolean)
Dim FName As String
Dim FPath As String
ThisWorkbook.Activate
FPath = ThisWorkbook.Path & "\" '& FName
FName = "Saved File" & Format(Date, "YYMMDD") & ".xlsx"
Application.DisplayAlerts = False
ThisWorkbook.Sheets.Copy
With ActiveWorkbook
.Sheets(1).UsedRange.Locked = True
.Sheets(1).Protect ""
.SaveAs Filename:=FPath & FName, FileFormat:=51
.Close
End With
Application.DisplayAlerts = True
End Sub
Note, usedrange is normally not the best practise to cover the entire range as it sometimes goes too large. However in your case you need to make sure all cells in the sheet are covered. Since all cells are protected by default when unchanged, usedrange will do the trick here nicely for the rest.
Edit, I glossed over most of the code as only the protect was relevant to the question. However as per comments, this leads to an issue. What happens is that you create a new workbook, and then copy the workbook with your code. This automatically creates a new workbook as well. This is the one which is saved, and newbook is closed without anything changed to it. I removed this part of the code. ActiveWorkbook after you copy should be the one containing your copied data, so I made this the one being locked and saved.
Related
I am very new to vba/macros, I created a macro that splits multiple sheets into new excel file. However, I get 1004 error when I run the macro.
Below is my code.
Private Sub CommandButton2_Click()
Dim workbookPath As String
workbookPath = Application.ActiveWorkbook.Path
Application.ScreenUpdating = False
Application.DisplayAlerts = False
For Each wSheet In ThisWorkbook.Sheets
wSheet.Copy
Application.ActiveWorkbook.SaveAs Filename:=workbookPath & "C\Path.xlsm" & wSheet.Name & ".xlsx"
Application.ActiveWorkbook.Close False
Next
Application.DisplayAlerts = True
Application.ScreenUpdating = True
End Sub
Note macro button I have created in sheet1 named "Part1" and want to create new files from next sheet onwards. Please help....
You are trying to insert two paths into your line of code.
Since you defined the workbookPath variable you don't need to use "C\Path.xlsm". You need to remove "C\Path.xlsm" and insert "\" before wSheet.Name. see basic code below.
Comment out the Debug.Print(s) after you have used to verify.
Dim workbookPath As String: workbookPath = ThisWorkbook.Path 'ThisWorkbook is the macro enabled workbook.
Debug.Print ThisWorkbook.Path 'open the immediate window to varify to verify the path of the macro enabled workbook.
For Each wSheet In ThisWorkbook.Sheets
wSheet.Copy
ActiveWorkbook.SaveAs Filename:=workbookPath & "\" & wSheet.Name & ".xlsx"
'When you save a sheet as a workbook it becomes the activeworkbook
Debug.Print ActiveWorkbook.Path & "\"; ActiveWorkbook.Name 'use to verify the path of the new workbook.
ActiveWorkbook.Close False
Next wSheet
End Sub
Hello so I used the below coding to try to "save as" the active worksheet to the current same folder, however the problem I am facing is that the file name does not appear as E6 however it is just a blank.
Also, is there a faster way to actually just omit the save as dialog and just save as a new workbook in the same folder as the macro? With the same file type as xls. Thank you.
Sub Button1_Click()
Dim varResult As Variant
Dim dirPath, fileName As String
dirPath = Application.ActiveWorkbook.Path
fileName = ActiveSheet.Range("E6").Value 'ActiveSheet.Name
Application.ScreenUpdating = False
Application.DisplayAlerts = False
varResult = Application.GetSaveAsFilename(FileFilter:= _
"Excel Files (*.xls), *.xls", Title:="Save As", _
InitialFileName:=dirPath & "\" & fileName)
ActiveWorkbook.SaveCopyAs fileName:=varResult
Application.DisplayAlerts = True
Application.ScreenUpdating = True
End Sub
To directly save without using the dialog, try the next code, please:
Sub testSaveAs()
Dim wb As Workbook
Set wb = ActiveWorkbook 'Use here your workbook
wb.SaveAs fileName:=ThisWorkbook.path & "\" & ActiveSheet.Range("E6").value & ".xls"
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 found the following code on this web site "save Excel file as CSV" is there any way with help of you'll I can auto run this code on specific time (11:00 pm every night), and save file name as current date (hr2015-05-05), any help will be greatly appreciated. Thanks
Private Sub Workbook_BeforeSave(ByVal SaveAsUI As Boolean, Cancel As Boolean)
Dim Sourcewb As Workbook
Dim Destwb As Workbook
Dim TempFileName As String
With Application
.ScreenUpdating = False
.EnableEvents = False
.DisplayAlerts = False
End With
Set Sourcewb = ActiveWorkbook
TempFileName = Sourcewb.FullName + ".csv"
'Copy the sheet to a new workbook
ActiveSheet.Copy
Set Destwb = ActiveWorkbook
'Save the new workbook and close it
With Destwb
.SaveAs Filename:=TempFileName, FileFormat:=xlCSV, ConflictResolution:=xlLocalSessionChanges
.Close SaveChanges:=False
End With
With Application
.ScreenUpdating = True
.EnableEvents = True
.DisplayAlerts = True
End With
End Sub
Edit fixed tag issue
I would do this one of two ways.
One would be through windows task scheduler. Where you will set up a task to open Excel and run it that way. See http://www.mrexcel.com/forum/excel-questions/302970-task-scheduler-vbulletin-script-auto-open-excel.html
Or
Use the code
Application.OnTime TimeValue("23:00:00"), SUBNAMEHERE
Changing SUBNAMEHERE to the sub where the code is. Not sure if it will run the beforesave part through
EDIT added code to have filename
Change TempFileName = Sourcewb.FullName + ".csv" to be
TempFileName = Sourcewb.FullName & " hr" & format(now,"YYYY-MM-DD") & ".csv"
I pieced together an Excel VBA script that writes all worksheets in an open workbook to separate, tab-delimited files (is this still a "macro"? I'm learning this in an Excel vacuum). It works well on one workbook at a time. Here it is.
Sub exportSheetsToText()
Dim sWb As String
Dim sFile As String
Dim oSheet As Worksheet
sWb = Left(ActiveWorkbook.FullName, InStr(ActiveWorkbook.FullName, ".") - 1)
For Each oSheet In Worksheets
oSheet.Copy
sFile = sWb & "-" & oSheet.Name & ".txt"
ActiveWorkbook.SaveAs fileName:=sFile, FileFormat:=xlText
ActiveWorkbook.Close SaveChanges:=False
Next oSheet
End Sub
I would like to scale this up so that I can apply this macro to a folder of workbooks. I wrote what I thought would loop over every workbook that satisfies the filter, but it doesn't write any of the .txt files. Here it is.
Sub exportsSheetsToTextForAll()
Dim sPath As String
Dim sWildcard As String
Dim sMacro As String
Dim oWb As Workbook
Dim oPersWb As Workbook
Application.AutomationSecurity = msoAutomationSecurityForceDisable
Set oPersWb = Workbooks("PERSONAL.XLSB")
sMacro = "'" & oPersWb.Name & "'" & "!exportSheetsToText()"
sPath = "C:\Users\richard\Documents\Research\Data\Excel\Datastream - payout"
sWildcard = "New*.xlsx"
sFile = Dir(sPath & "\" & sWildcard)
Do While Len(sFile) > 0
Workbooks.Open Filename:=sPath & "\" & sFile
Application.Run sMacro
ActiveWorkbook.Close SaveChanges:=False
sFile = Dir
Loop
End Sub
It loops through all of my test files, but I don't see any effects (i.e., no .txt files and no errors).
Eventually I will run this on very large workbooks with macros, so it is important to disable the macros (I don't have the macros locally, they're on a dedicated data machine) and close one large workbook before opening the next.
Any ideas? Thanks!
#Siddarth's idea of passing an argument to exportSheetsToText() was the key. As well I had an error with macro name passed to Application.Run. The following works and is much cleaner.
Sub exportsSheetsToTextForAll()
Application.AutomationSecurity = msoAutomationSecurityForceDisable
excelFiles = Dir(ThisWorkbook.Path & "\" & "New*.xlsx")
fromPath = ThisWorkbook.Path
Do While Len(excelFiles) > 0
Debug.Print Files
Set oWb = Workbooks.Open(Filename:=fromPath & "\" & excelFiles)
Application.Run "exportSheetsToText", oWb
oWb.Close SaveChanges:=False
excelFiles = Dir
Loop
End Sub
Sub exportSheetsToText(iWb As Workbook)
For Each ws In iWb.Worksheets
ws.Copy
Set wb = ActiveWorkbook
textFile = Left(iWb.FullName, InStr(iWb.FullName, ".") - 1) & "-" & ws.Name & ".txt"
wb.SaveAs Filename:=textFile, FileFormat:=xlText
wb.Close SaveChanges:=False
Next ws
End Sub