I have a huge Excel spreadsheet that I need to allow access to a large set of users so they can manipulate it for their customers, but I don't want them to be able to overwrite the original file (a variable easily set in Excel) or save their file outside the current folder - so I want to force them in a "saveas" mode, and force the file to be saved in that folder. Otherwise, they won't be able to save. I'm not much of a VBA person, and I've found a lot of examples that may work, but nothing seems to be exactly what I need or maybe I'm not smart enough to figure it out. I found this code, but I'm not sure it FORCES the issue. Help?
I've tried to manage this in GPOs but everything seems to give them access to download the folder and save in other places.
Sub ExampleToSaveWorkbookSet()
Dim wkb As Workbook
'Adding New Workbook
Set wkb = Workbooks.Add
'Saving the Workbook
wkb.SaveAs "C:\WorkbookName.xls"
'OR
'wkb.SaveAs Filename:="C:\WorkbookName1.xls"
End Sub
Expected output is the amended Excel file saved in the original directory with a different name, or not at all.
Here's a macro that runs on open and immediately saves as .xlsx to a user location you can specify. Unfortunately the original needs to be .xlsm to store a macro.
This macro is to be located in the "ThisWorkbook" object. It will exit before making a copy when you open the workbook.
Private Sub Workbook_Open()
Dim wb As Workbook
Set wb = ActiveWorkbook
vWbName = wb.Name
vUserProf = Environ("USERPROFILE")
vx = InStr(1, vUserProf, "Users\")
If "<Use your own profileID>" = Mid(vUserProf, vx + 6) Then Exit Sub
vDir = vUserProf & "\Downloads\"
vWbName = Left(vWbName, Len(vWbName) - 5) & ".xlsx"
wb.SaveAs vDir & vWbName, FileFormat:=xlOpenXMLWorkbook, CreateBackup:=False
MsgBox "You are now using a copy of the original"
End Sub
Related
Good day all:
I'm trying to use a ActiveX command button to copy excel worksheets into another file. Here's the background:
I have excel log sheets that are being filled up every day. The logs have a set criterion (A, B, C, etc.) being run daily. While we still want to keep the logs in a daily file, I want a command button to be able to export to another workbook as a master file (e.g. "A_Masterfile", "B_Masterfile", etc.).
I've tried researching, but all these requirements come from different sites/pages. But since the method they use are so different, I'm having a hard time trying to get all Syntax to fit so that one code can do everything.
As a rundown, here's what I want it to do:
Export active worksheet to another workbook
a) If workbook exists, copy sheet to end of workbook
b) If workbook does not exist, create workbook and copy sheet
Destination workbook is based on a cell (criterion A, B, etc.)
Destination workbook might be in a different folder as source worksheet/workbook
Based on what I'm researching so far, this is what I'm turning up with.
When simply copying, this is what I read, but I could not get it to work.
ActiveSheet.Copy After:=Workbooks("Destination.xlsx").Worksheets(Worksheets.Count)
For Creating New File, this is what I read, but even from the original site, they said the problem was it copies the whole workbook, not just one specific sheet.
ActiveWorkbook.SaveAs "C:\path\Destination.xlsx"
Finally, I read about concatenation to create "Destination" file name based on a cell value. However, I got so lost with all the syntax. I tried simply copy pasting but I couldn't get it to work.
This is quite a bit to ask. Thanks so much in advance for all your help!
Please let me know if I can clarify anything.
P.S. Extra note: I've done some QBasic and MATLAB and a tiny bit of JAVA programming in school, so I got the logic part down. But I am quite new to VBA syntax, so extra information would be appreciated. :)
Update:
I just learned about "Record Macro" and I tried using it
I got this from it and it works:
Sheets("SourceSheet").Select
ActiveSheet.CheckBoxes.Add(639, 30, 58.8, 16.8).Select
ActiveSheet.CheckBoxes.Add(639.6, 44.4, 58.8, 16.8).Select
ActiveSheet.CheckBoxes.Add(639.6, 61.2, 58.8, 16.8).Select
ActiveSheet.OptionButtons.Add(1279.8, 37.8, 20.4, 18).Select
ActiveSheet.OptionButtons.Add(1280.4, 57, 21.6, 17.4).Select
Sheets("SourceSheet").Copy After:=Workbooks("DestinationMasterFile.xlsx").Sheets(1)
Windows("SourceWorkBook.xlsm").Activate
It works, but only put it after the first sheet instead of putting it in the end. I know it comes from the .Sheets(1), but I don't know how to write it otherwise. Thanks.
I have done a lot more research and trial and error, and I came up with a working code. This might be messy, but it works. Any further improvements are appreciated.
Private Sub CommandButton1_Click()
'Code for Locking
Sheets("W").Unprotect
Range("A1:BZ125").Locked = True
Sheets("W").Protect Password:="hello"
'Code for Copying
'Declarations
Dim Wk As Workbook
Dim FName As String
Dim FNameTwo As String
Dim FilePath As String
Dim TestStr As String
Dim wb As Workbook
'Initializing Constants
Set wb = ThisWorkbook
FName = "C:\Users\PHReyesDa\Desktop\" & Range("BO1") & ".xlsx"
FNameTwo = Range("BO1") + ".xlsx"
'If statement Setup (if exist)
FilePath = FName
TestStr = ""
On Error Resume Next
TestStr = Dir(FilePath)
On Error GoTo 0
'If statement
If TestStr = "" Then
'If not existing, create new file
MsgBox "File didn't exist yet; new file created"
Set Wk = Workbooks.Add
Application.DisplayAlerts = False
Wk.SaveAs Filename:=FName
Application.DisplayAlerts = True
Workbooks(FNameTwo).Close SaveChanges:=True
End If
'Reopens Master File
Workbooks.Open FName
wb.Activate
'Find number of worksheets in destination workbook to worksheet could be copied to end of workbook
Dim Num As Integer
Num = Workbooks(FNameTwo).Worksheets.Count
'Copy source worksheet to (the end of) destination workbook
Sheets("W").Select
Sheets("W").Copy After:=Workbooks(FNameTwo).Worksheets(Num)
'Close and save new workbook, confirmation of successful copy
Workbooks(FNameTwo).Close SaveChanges:=True
MsgBox "Worksheet successfully exported and saved to master file"
End Sub
I have two workbooks, a shared "xlsx" file A which stores data and no-sharing "xlsm" file B which contains my macros. I would like maintain periodic tracking of changes in file A and password-protect this change history. I know there is a "Track Changes" feature in file A and it could create a separate sheet containing the change history. However, this sheet is within workbook A, which is being shared. Is there a way to write a macro in B to periodically extract this change history from A, put it into a "xlsx" file C with password?
The point here is I would like to prevent the change history to be compromised. Only I have access to it. Note that I can not make file A "macro enabled" and write macro in it.
Thank.
When you open the Shared WB, update the change info, then copy the History sheet
Sub Demo()
Dim wbShared As Workbook
Dim wbHistory As Workbook
Set wbHistory = Application.Workbooks.Open( _
Filename:="\\Path\To\Your\History\FileC.xlsx", _
Password:="Password")
Set wbShared = Application.Workbooks.Open( _
FileName:="\\Path\To\Your\Shared\FileA.xlsx")
' Generate History Sheet (maybe change xlAllChanges to suit needs)
With wbShared
.HighlightChangesOptions _
When:=xlAllChanges, _
Who:="Everyone"
.ListChangesOnNewSheet = True
End With
' Copy out History to FileC
wbShared.Worksheets("History").Copy After:=wbHistory.Sheets(wbHistory.Sheets.Count)
' Clean Up
wbShared.Close False
wbHistory.Close True
End Sub
Using your private workbook, you can use macros to open the shared workbook and copy the sheet into the private workbook again.
EDIT: Sorry, I missed the part about saving it into a file C.
Here is to get you started:
Sub wbCopy()
Dim sharedWb, myWb As Workbook
Dim sharedWs As Worksheet
Set myWb = New Workbook
Workbooks.Open Filename:="192.168.0.10\sharedWorkbook.xls", ReadOnly:=True
Set sharedWb = "sharedWorkbook.xls"
Set sharedWs = sharedWb.Worksheets(2)
sharedWs.Copy myWb.Worksheets(Sheets.Count)
Workbooks("sharedWorkbook.xls").Close
myWb.SaveAs Filename:="File C.xls"
End Sub
I'm currently working at a Uni project using Excel VBA and I'm trying to find a way to create an excel that will self destruct if it doesn't find the "Key". And in the event it's entirely impossible, then at least ensure there's none of the data or VBA code left.
The idea is that, using
Private Sub Workbook_Open()
Dim direct As String, name As String
name = ActiveWorkbook.Name
ChDir ThisWorkbook.Path
direct = ThisWorkbook.Path
Call Checker(direct, name)
End Sub
Upon opening the excel, it will look for "Key.txt" which should be within the same folder as the excel and check if the one string of text inside the document matches with "Code" which is a "Public Const" inside the project.
I've been trying to find a way to read the "Key.txt" without opening it, but haven't turned up anything.
On the other hand, I've been testing out various ways of making the program delete the original excel file, varying levels of success. So a somewhat roundabout way I've been testing out is to have the excel SaveAs a ".xlsx" and erase the original file before closing itself, but it doesn't work out as I've hoped for.
This is the code I've used for the "Self-Destruct" method:
Option Explicit
Function Checker(MyPath As String, name As String)
On Error Resume Next
Application.DisplayAlerts = False
Dim myPath2 As String
Dim ws As Worksheet
Dim FSO As Object
myPath2 = MyPath
ActiveWorkbook.SaveAs Filename:=MyPath & "\0_0.xlsx", FileFormat:=xlOpenXMLWorkbook, CreateBackup:=False
Sheets.Add After:=Sheets(Sheets.Count)
ActiveSheet.Name = "1"
For Each ws In Worksheets 'Deletes all other sheets
If ws.Name <> "1" Then ws.Delete
Next
Set FSO = CreateObject("scripting.filesystemobject")
If Right(MyPath, 1) = "\" Then MyPath = Left(MyPath, Len(MyPath) - 1)
If FSO.FolderExists(MyPath) = False Then MsgBox MyPath & " doesn't exist"
FSO.deletefile MyPath & "\" & name, True 'Deletes original file
ActiveWorkbook.Save
ActiveWorkbook.Close
End Function
Having a self-destructing file is an interesting idea. The short answer is that you cannot delete a running VBA macro. Therefore, no VBA macro can essentially self destruct. Yet, there are two options I can think of:
(1) Remove everything but the running macro. The following code might be helpful to achieve that.
http://www.erlandsendata.no/english/index.php?d=envbavbedeleteallmacros
(2) Close the file and ask Windows to delete the file afterwards for you using the task planner. The following post on SO might be able to help with that.
Using Excel vba Macro to be run through Windows Schedule Task
Other tempting solutions might be to save the file as .xlsx or to create a new Excel file, copy the above code from option 1 into that file, call the newly created code, which essentially deletes the original file.
But the real questions I'd ask myself would be: How did this person got the self-destructing file? Was it by email and the file is still in the email? Has the file been duplicated along the way? Are there hidden copies in some Temp-Folders (remember Excel Auto-Safe every xx minutes in case of computer crash to preserve your work)? Is the person enabling macros when opening the file (to allow self-destruction)? Can the person resore the file with the many free programs out there to recover files from a Windows machine (extremely easy as Windows does not delete the file or writes cryptical data on top to ensure it cannot be recovered, but merely "marks" that space on the HD where the file was as free to use for the next file to come)?
I'm trying to save a macro-enabled Excel workbook as a csv file, overwriting the old one (below I had to change the name of the folder and the Sheet, but that doesn't seem to be the issue).
Sub SaveWorksheetsAsCsv()
Dim SaveToDirectory As String
Dim CurrentWorkbook As String
Dim CurrentFormat As Long
CurrentWorkbook = ThisWorkbook.FullName
CurrentFormat = ThisWorkbook.FileFormat
SaveToDirectory = "\MyFolder\"
Application.DisplayAlerts = False
Application.AlertBeforeOverwriting = False
Sheets("My_Sheet").Copy
ActiveWorkbook.SaveAs Filename:=SaveToDirectory & "My_Sheet" & ".csv", FileFormat:=xlCSV
ActiveWorkbook.Close SaveChanges:=False
ThisWorkbook.Activate
ThisWorkbook.SaveAs Filename:=CurrentWorkbook, FileFormat:=CurrentFormat
Application.DisplayAlerts = True
Application.AlertBeforeOverwriting = True
End Sub
Sometimes it fails with
Runtime Error 1004: method saveas of object _workbook failed**)
The debugger points out:
ActiveWorkbook.SaveAs Filename:=SaveToDirectory & "My_Sheet" & ".csv", FileFormat:=xlCSV
I googled and some of the solutions I tried were:
Specifiying that the directory is a string
Avoid any special character in the file name or folder (seen here)
Copy paste the worksheet as value before saving it as .csv (seen here)
Specifying the FileFormat with the .csv code number (seen here)
Disabling/Re-enabling some of the alerts
Adding other fields in the ActiveWorkbook.SaveAs row, regarding passwords, creating backups etcetc
Still, it might run correctly up to 50-60 times in a row, and then at some point fail again.
Any suggestion, except stop using VBA/Excel for this task, which will happen soon, but I can't for now.
EDIT: Solved thanks to Degustaf suggestion. I made only two changes to Degustaf's suggested code:
ThisWorkbook.Sheets instead of CurrentWorkbook.Sheets
FileFormat:=6 instead of FileFormat:=xlCSV (apparently is more robust
to different versions of Excel)
Sub SaveWorksheetsAsCsv()
Dim SaveToDirectory As String
Dim CurrentWorkbook As String
Dim CurrentFormat As Long
Dim TempWB As Workbook
Set TempWB = Workbooks.Add
CurrentWorkbook = ThisWorkbook.FullName
CurrentFormat = ThisWorkbook.FileFormat
SaveToDirectory = "\\MyFolder\"
Application.DisplayAlerts = False
Application.AlertBeforeOverwriting = False
ThisWorkbook.Sheets("My_Sheet").Copy Before:=TempWB.Sheets(1)
ThisWorkbook.Sheets("My_Sheet").SaveAs Filename:=SaveToDirectory & "My_Sheet" & ".csv", FileFormat:=6
TempWB.Close SaveChanges:=False
ThisWorkbook.SaveAs Filename:=CurrentWorkbook, FileFormat:=CurrentFormat
ActiveWorkbook.Close SaveChanges:=False
Application.DisplayAlerts = True
Application.AlertBeforeOverwriting = True
End Sub
I generally find that ActiveWorkbook is the problem in these cases. By that I mean that somehow you don't have that workbook (or any other) selected, and Excel doesn't know what to do. Unfortunately, since copy doesn't return anything (the copied worksheet would be nice), this is a standard way of approaching this problem.
So, we can approach this as how can we copy this sheet to a new workbook, and get a reference to that workbook. What we can do is create the new workbook, and then copy the sheet:
Dim wkbk as Workbook
Set Wkbk = Workbooks.Add
CurrentWorkbook.Sheets("My_Sheet").Copy Before:=Wkbk.Sheets(1)
Wkbk.SaveAs Filename:=SaveToDirectory & "My_Sheet" & ".csv", FileFormat:=xlCSV
Wkbk.Close SaveChanges:=False
Or, there is an even better approach in a situation like this: WorkSheet supports the SaveAs method. No copy necessary.
CurrentWorkbook.Sheets("My_Sheet").SaveAs Filename:=SaveToDirectory & "My_Sheet" & ".csv", FileFormat:=xlCSV
I will warn you to resave the workbook to its original name afterwards, if it is staying open, but you already have that in your code.
This is a year old, but I'll add something for future readers
You won’t find a lot of documentation in Excel help for Run-time error 1004 as Microsoft doesn't consider it to be an Excel error.
The answers above are 100% valid but sometimes it helps to know what is causing the problem so you can avoid it, fix it earlier or fix it more easily.
The fact that this is an intermittent fault, and it is fixed by saving with the full path and file name tells me that either your macro may be trying to save an .xlsb file to the autorecover directory after an auto file recovery.
Alternatively, you may have edited the file's path or filename yourself.
You can check the path and filename with:-
MsgBox ThisWorkbook.FullName
You should see something like this in the message box.
C:\Users\Mike\AppData\Roaming\Microsoft\Excel\DIARY(version 1).xlxb
If so the solution is (as stated above by others) to save your file to its correct path and file name. This can be done with VBA or manually.
I am now in the habit of manually saving the file with its correct path and filename as a matter of course after any autorecover action as it takes seconds and I find it quicker (if this is not a daily occurrence). Thus, the macros will not encounter this fault you run it. Remember that while my habit of manually saving .xlxb files to .xlsm files immediately after a recovery won't help a novice that you give the worksheet to.
A note on Hyperlinks
After this error: If you have hyperlinks in your worksheet created with Ctrl+k in all likelihood, you will have something like "AppData\Roaming\Microsoft\", "\AppData\Roaming\", "../../AppData/Roaming/"or "....\My documents\My documents\" in multiple hyperlinks after file recovery. You can avoid these by attaching your hyperlinks to a text box or generating them with the HYPERLINK function.
Identifying and Repairing them is a little more complicated
First, examine the hyperlinks and determine the erroneous strings and the correct string for each error. Over time, I have found several.
Excel doesn't provide a facility in the 'Go To Special' menu to search for hyperlinks created with Ctrl+k.
You can automate the identification of erroneous hyperlinks in a helper column, say column Z and using the formula
=OR(ISNUMBER(SEARCH("Roaming", Link2Text($C2),1)),ISNUMBER(SEARCH("Roaming", Link2Text($D2),1)))
where Link2Text is the UDF
Function Link2Text(rng As Range) As String
' DO NOT deactivate.
' Locates hyperlinks containing 'roaming' in column Z.
' Identify affected hyperlinks
If rng(1).Hyperlinks.Count Then
Link2Text = rng.Hyperlinks(1).Address
End If
End Function
My VBA to correct the errors is as follows
Sub Replace_roaming()
' Select the correct sheet
Sheets("DIARY").Select
Dim hl As Hyperlink
For Each hl In ActiveSheet.Hyperlinks
hl.Address = Replace(hl.Address, "AppData\Roaming\Microsoft\", "")
Next
For Each hl In ActiveSheet.Hyperlinks
hl.Address = Replace(hl.Address, "AppData\Roaming\", "")
Next
For Each hl In ActiveSheet.Hyperlinks
hl.Address = Replace(hl.Address, "../../AppData/Roaming/", "..\..\My documents\")
Next
For Each hl In ActiveSheet.Hyperlinks
hl.Address = Replace(hl.Address, "..\..\My documents\My documents\", "..\..\My documents\")
Next
Application.Run "Recalc_BT"
' Move down one active row to get off the heading
ActiveCell.Offset(1, 0).Select
' Check active row location
If ActiveCell.Row = 1 Then
ActiveCell.Offset(1, 0).Select
End If
' Recalc active row
ActiveCell.EntireRow.Calculate
' Notify
MsgBox "Replace roaming is now complete."
End Sub
I also recommend you get in the habit of doing regular backups and not relying on autorecover alone. If it fails, you have nothing since your last full backup.
While the worksheet is being fragile backup often, like every hour or after any significant import of new data.
The following shortcuts will backup your worksheet in seconds: Ctrl+O, [highlight the filename], Ctrl+C, Ctrl+V, [ X ]. Regular backups allow you to go immediately to your most recent backup without having to restore from last night's backup file especially if you have to make a request of another person to do this.
It's been a while since the last answer here, but I want to share my experience from today:
After weeks of reliable operation, I ran into the same error all of a sudden without having anything changed in the code section where the workbook is saved.
Thanks to the previous answers I updated my saveas statement from a simple
wb.saveas strfilename
to
wb.saveas Filename:=strfilename, Fileformat:= xlWorkbookDefault
et voilà: it worked again.
Sometimes the Microsoft applications behave really strange...
Try combining the Path and the CSV file name into a string variable and drop the .csv; that is handled by the FileFormat. Path must be absolute starting with a drive letter or Server Name:
Dim strFullFileName as String
strFullFileName = "C:\My Folder\My_Sheet"
If on a Server then it would look something like this:
strFullFileName = "\\ServerName\ShareName\My Folder\My_Sheet"
Substiture ServerName with your Server name and substitute ShareName with the your network Share name e.g. \\data101\Accounting\My Folder\My_Sheet
ActiveWorkbook.SaveAs Filename:=strFullFileName,FileFormat:=xlCSVMSDOS, CreateBackup:=False
I had a similar issue however for me the problem was I was creating the Filename based on strings extracted from a workbook and sometimes these strings would have characters that can't be in a filename.
Removing these characters did the trick for me!
For me there was an issue with not all formulas being calculated, despite having it on "Automatic". I pressed calculate on the bottom left 100 times and then it magically worked.
My function is as follows:
Sub saveCSV()
Application.DisplayAlerts = False
ActiveWorkbook.SaveAs Filename:= _
"c:\temp\file.csv", FileFormat:=xlCSV _
, CreateBackup:=False
End Sub
I'm trying to export the active worksheet to CSV. When I run the code in the title, Book1.xlsm changes to file.csv and Sheet1 changes to file. The export works fine. How can I do the export without these unwanted side effects?
That's always how SaveAs has worked. The only way to get around this is to copy the worksheet and do a SaveAs on the copy, then close it.
EDIT: I should add an example as it's not that difficult to do. Here's a quick example that copies the ActiveSheet to a new workbook.
Dim wbk As Workbook
Set wbk = Workbooks.Add
ActiveSheet.Copy wbk.Sheets(1) ' Copy activesheet before the first sheet of wbk
wbk.SaveAs ....
wbk.Close
A complicated workbook may get issues with links and macros, but in ordinary scenarios this is safe.
EDIT 2: I'm aware of what you're trying to do, as your other question was about trying to trigger an export on every change to the sheet. This copy sheet approach presented here is likely to be highly disruptive.
My suggestion is to write a CSV file by hand to minimise GUI interruption. The sheet is likely to become unusable if the saves are occurring at high frequency. I wouldn't lay the blame for this at the door of Excel, it simply wasn't built for rapid saves done behind the scenes.
Here's a little routine that does what you want by operating on a copy of the original ... copy made via file scripting object. Hardcoded to operate on "ThisWorkbook" as opposed to active workbook & presumes ".xlsm" suffix - could tweak this to do the job I think:
Public Sub SaveCopyAsCsv()
Dim sThisFile As String: sThisFile = ThisWorkbook.FullName
Dim sCsvFile As String: sTempFile = Replace(sThisFile, ".xlsm", "_TEMP.xlsm")
ThisWorkbook.Save ' save the current workbook
' copy the saved workbook ABC.xlsm to TEMP_ABC.xlsm
Dim fso As Object: Set fso = CreateObject("Scripting.FileSystemObject")
On Error Resume Next
Call fso.deletefile(sTempFile, True) ' deletes prev temp file if it exists
On Error GoTo 0
Call fso.CopyFile(sThisFile, sTempFile, True)
' open the temp file & save as CSV
Dim wbTemp As Workbook
Set wbTemp = Workbooks.Open(sTempFile) ' open the temp file in excel
' your prev code to save as CSV
Application.DisplayAlerts = False
ActiveWorkbook.SaveAs FileName:="c:\temp\file.csv", FileFormat:=xlCSV, CreateBackup:=False
wbTemp.Close ' close the temp file now that the copy has been made
Application.DisplayAlerts = True
' delete the temp file (if you want)
On Error Resume Next
Call fso.deletefile(sTempFile, True) ' deletes the temp file
On Error GoTo 0
End Sub