how can I make sure that my VBA code is not overwriting existing files while saving?
Example: I'm saving every sheet as a new workbook, and want to have v1, v2, v3 etc. With the code below I'm always overwriting the existing file, as every file I save has the same file name with "_V1" ending...
NewWbName = Left(wbSource.Name, InStr(wbSource.Name, ".") - 1)
For i = 1 To 9
'check for existence of proposed filename
If Len(Dir(wbSource.Path & Application.PathSeparator & NewWbName & "_V" & i & ".xlsx")) = 0 Then
wbTemplate.SaveAs wbSource.Path & Application.PathSeparator & NewWbName & "_V" & i & ".xlsx"
Exit For
End If
Next i
If i > 9 Then
'_V1.xlsx through _V9.xlsx already used; deal with this situation
MsgBox "out of options"
wbTemplate.Close False 'close template
Next wsSource
wbSource.Close False 'close source
End If
End Sub
Loop through various _Vn.xlsx variations until you find one that isn't there.
dim i as long, NewWbName as string
NewWbName = Left(wbSource.Name, InStr(wbSource.Name, ".") - 1)
for i=1 to 9
'check for existence of proposed filename
if len(dir(wbSource.Path & Application.PathSeparator & NewWbName & "_V" & i & ".xlsx")) = 0 then
wbTemplate.SaveAs wbSource.Path & Application.PathSeparator & NewWbName & "_V" & i & ".xlsx"
exit for
end if
next i
if i>9 then
'_V1.xlsx through _V9.xlsx already used; deal with this situation
msgbox "out of options"
end if
If you are going to raise the loop into double digits, perhaps ... & "_V" & Format(i, "00") & ".xlsx would be better so that a folder sorted by name puts them in the correct order.
Recommend using a date and time stamp for so many versions.
“V” & Format(date, “yyyymmdd”) & format(time, “hhmmss”) & “.xlsx”
Yes, you may still want to check for an existing file, but it’s seldom the user will submit input in less than a second
Related
I am having trouble with creating new version, with the dates selected by the users.
So here I have 2 separate workbooks:
1) Macro - where the users will click the button and generate the macro
2) Report template - when the users click the macro, the figures will be generated into the templates, with the dates in the naming convention, and the version.
The report template naming convention looks like this : BSLCT_DDMMYYYYG where DDMMYYYY is the date, that the users will select in the report template.
So when the report is generated, it will SaveAs another file i.e BSLCT_10072020G.
The code I used to generate is as follow:
Sub Naming reports()
Windows("BSTCT_DDMMYYYYG.xls").Activate
Sheets("G.0(GenInfo)").Select
ActiveWorkbook.SaveAs Path & "\BSLCT_" & REPORT_DATE & "G.xls"
ActiveWorkbook.Close
End Sub
where i define the REPORT_DATE before that.
Now, the users need to have a versioning in their file naming as well, which is something like BSTCT_DDMMYYYYG_vX.xls. So as long as the users run the macro, the macro will generate a new version, regardless of whether the date has already existed.
I managed to create a _v1 using the following codes:
Sub version
Windows("BSTCT_DDMMYYYYG.xls").Activate
Sheets("G.0(GenInfo)").Select
If InStr(ActiveWorkbook.Name, "_v") = 0 Then
fileName = ActiveWorkbook.Path & "\" & Left(ActiveWorkbook.Name,
InStr(ActiveWorkbook.Name, ".") - 1) & "_v1." & ext
ActiveWorkbook.SaveAs (fileName)
Else
index = CInt(Split(Right(ActiveWorkbook.Name, Len(ActiveWorkbook.Name) - InStr(ActiveWorkbook.Name, "_v") - 1), ".")(0))
index = index + 1
fileName = ActiveWorkbook.Path & "\" & Left(ActiveWorkbook.Name,InStr(ActiveWorkbook.Name, "_v") - 1) & "_v" & index & "." & ext
End If
ActiveWorkbook.SaveAs (fileName)
End Sub
However, after generating the v1, I couldn't generate v1 onwards, because i need to activate the "BSTCT_DDMMYYYYG.xls" window to pick up the report date, this will then break my codes.
Also, while I am adding the version, at the same time i would like to get the DDMMYYYY into the naming too.
How can I do that?
I really appreciate your helps.
now i am trying to keep adding the newer version with the following code:
Sub SaveNewVersion()
Dim fileName As String, index As Long, ext As String, sVersion As String
arr = Split(ActiveWorkbook.Name, ".")
ext = arr(UBound(arr))
sVersion = "_v"
Windows("BSLCT_DDMMYYYYG.xls").Activate
Sheets("G.0(GenInfo)").Select
If InStr(ActiveWorkbook.Name, "_v") = 0 Then
fileName = ActiveWorkbook.Path & "" & Left(ActiveWorkbook.Name, InStr(ActiveWorkbook.Name, ".") - 1) & "_v1." & ext
ActiveWorkbook.SaveAs "\BSLCT_" & REPORT_DATE & "G" & sVersion & index & ".xls"
Else
index = CInt(Split(Right(ActiveWorkbook.Name, Len(ActiveWorkbook.Name) - InStr(ActiveWorkbook.Name, "_v") - 1), ".")(0))
index = index + 1
fileName = ActiveWorkbook.Path & "" & Left(ActiveWorkbook.Name, InStr(ActiveWorkbook.Name, "_v") - 1) & "_v" & index & "." & ext
ActiveWorkbook.SaveAs "\BSLCT_" & REPORT_DATE & "G " & sVersion & index & ".xls"
End If
ActiveWorkbook.Close
End Sub
but at first it keeps replacing my first version, and then saying that this line of code:
index = CInt(Split(Right(ActiveWorkbook.Name, Len(ActiveWorkbook.Name) - InStr(ActiveWorkbook.Name, "_v") - 1), ".")(0)) has syntax error.
Does anyone can help on this? I am really clueless where can I modify this.
Try this:
Sub SetNewName()
Dim wbk As Workbook
Dim sDate As String
Dim sVersion As String
sDate = Format(Date, "ddMMyyyy")
sVersion = "_v1"
Set wbk = Application.Workbooks("BSTCT_DDMMYYYYG.xls")
wbk.SaveAs ActiveWorkbook.Path & "\" & sDate & sVersion & ".xls"
End Sub
Background:
Several years ago, I made a spreadsheet to generate a list of samples to be tested each day. The user (usually me) checks boxes to indicate which tests' samples to list. Then the "save load sheet" button uses VBA to requery a database connection for sample information, populates the formatted list through a complex series of formulas, copies the values from the formula sheet ("Generator") to another sheet ("LoadSheet"), copies that sheet to a new workbook, and saves it with the date as filename in a folder according to year and month.
It worked pretty dependably for about 5 years, right up until a couple of weeks ago when my computer was upgraded from Windows 7 with Office 2013 to Windows 10 with Office 2016.
Problem:
Now, when I try to execute the code, I get Runtime error '1004: Copy method of Worksheet class failed."
Sub SaveAs()
'Copy to new workbook.
Sheets("LoadSheet").Copy '<---This is the line that fails.
' Check directory, create if necessary.
If Dir("G:\Load Sheets\" & Year(Now) & "\" & MonthName(Month(Now)) & "\", vbDirectory) = "" Then
If Dir("G:\Load Sheets\" & Year(Now) & "\", vbDirectory) = "" Then
MkDir ("G:\Load Sheets\" & Year(Now) & "\")
End If
MkDir ("G:\Load Sheets\" & Year(Now) & "\" & MonthName(Month(Now)) & "\")
End If
'Save.
'If the worksheet already exists, the user will be asked whether to replace the file or not.
'If it already exists and is currently open, an error could arise.
'Hopefully that won't come up before I have time to think of a way to implement error handling.
ActiveWorkbook.SaveAs Filename:= _
"G:\Load Sheets\" & Year(Now) & "\" & MonthName(Month(Now)) & "\" & Format(Now, "mm-dd-yy") & "x", _
FileFormat:=xlOpenXMLWorkbook, CreateBackup:=False
Range("A1").Select
Sheets(1).Select
Range("A1").Select
ActiveWorkbook.Save
Application.CutCopyMode = False
ThisWorkbook.Activate
Workbooks(Format(Now, "mm-dd-yy") & "x.xlsx").Activate
End Sub
This is the code that saves the file. It fails on the line indicated.
What I've already tried:
I've tried right-clicking on the worksheet tab, clicking "Move or Copy..." and try to create a copy in a new workbook. Nothing happens. No error message, no new worksheet/book, nothing.
Same thing happens if I try to "move" rather than "copy."
If I try right-clicking and creating a copy in the same workbook, I get a new blank sheet, rather than a copy.
I tried repairing my Office installation, but that didn't help.
I read about some cases where users suspected file corruption, so I even tried manually copying the contents to a new workbook by Ctrl+A,C,V one sheet at a time, and then doing the same for the code. No effect.
I tried Sheets(Worksheets.Count).Select followed by ActiveSheet.Copy, since the sheet is the last one in the book, but of course that didn't work.
I read that it could be because the workbook needed to be saved first, so I tried ActiveWorkbook.Save before the copy. Still the same result.
I tried decompiling/recompiling the worksheet to no effect.
It worked fine on Windows 7 with Office 2013 (and still does on a co-worker's Win7/Excel2013 machine), but I couldn't find anything online about problems with the Sheets.Copy method in Excel 2016, so I don't know if either of those is relevant.
Any ideas?
EDIT: I've tried it on an identical computer (also running Windows 10 & Office 2016) and had the same result. I'm not sure how commonly an installation becomes corrupted, but this feels like more than coincidence. The other computer is rarely used by anyone, and it's being used primarily to run an instance of SQL Server Express and a Windows service I wrote, so I suspect that makes corruption even less likely.
I've got a workaround for now... I just save the file with the filename and path I would have used for the copy, then do a For Each on each worksheet, deleting anything not named "LoadSheet."
Sub SaveAs()
On Error GoTo SaveAs_Err
'Check directory, create if necessary.
If Dir("G:\Load Sheets\" & Year(Now) & "\" & MonthName(Month(Now)) & "\", vbDirectory) = "" Then '<> "G:\Load Sheets\" & Year(Now) & "\" & MonthName(Month(Now)) & "\" Then
If Dir("G:\Load Sheets\" & Year(Now) & "\", vbDirectory) = "" Then '<> "G:\Load Sheets\" & Year(Now) & "\" Then
MkDir ("G:\Load Sheets\" & Year(Now) & "\")
End If
MkDir ("G:\Load Sheets\" & Year(Now) & "\" & MonthName(Month(Now)) & "\")
End If
' Turn off alerts. They're annoying. I don't care if it's poor form, I just want to be done with this. I'm not being paid to write code.
Application.DisplayAlerts = False
'Save, disregarding consequences.
ActiveWorkbook.SaveAs Filename:= _
"G:\Load Sheets\" & Year(Now) & "\" & MonthName(Month(Now)) & "\" & Format(Now, "mm-dd-yy") & "x", _
FileFormat:=xlOpenXMLWorkbook, CreateBackup:=False
' Remove extraneous sheets.
Dim ws As Worksheet
For Each ws In ActiveWorkbook.Sheets
If ws.Name <> "LoadSheet" Then ws.Delete
Next
Application.DisplayAlerts = True
Exit Sub
SaveAs_Err:
Application.DisplayAlerts = True
MsgBox ("An error occurred while saving the file.")
Debug.Print "Error " & Err.Number & ": " & Err.Description
End Sub
I'm still interested in fixing the root cause of this problem, so if anyone has ideas, I'm all ears! I'll probably still try the uninstall/reinstall, but I don't expect it to change anything.
Brute force fix, try:
Sub SaveAs()
Dim newWB as Workbook, i as Integer, copyRange as Range, fName as String
Set newWB = Workbooks.Add
While newWB.Worksheets.Count > 1
newWB.Worksheets(newWB.Worksheets.Count).Delete
Wend
newWB.Worksheets(1).Name = "LoadSheet"
' get a handle on the sheet's usedRange object
Set copyRange = ThisWorkbook.Worksheets("LoadSheet").UsedRange
' assign the values to the newWB.Worksheets(1)
'newWB.Worksheets(1).Range(copyRange.Address).Value = copyRange.Value
copyRange.Copy Destination:=newWB.Worksheets(1).Range(copyRange.Address)
'Check directory, create if necessary.
If Dir("G:\Load Sheets\" & Year(Now) & "\" & MonthName(Month(Now)) & "\", vbDirectory) = "" Then
If Dir("G:\Load Sheets\" & Year(Now) & "\", vbDirectory) = "" Then
MkDir ("G:\Load Sheets\" & Year(Now) & "\")
End If
MkDir ("G:\Load Sheets\" & Year(Now) & "\" & MonthName(Month(Now)) & "\")
End If
fName = "G:\Load Sheets\" & Year(Now) & "\" & MonthName(Month(Now)) & "\" & Format(Now, "mm-dd-yy") & "x"
If Dir(fName & ".xlsx") <> "" Then Kill fName & ".xlsx"
If Dir(fName & ".xlsm") <> "" Then Kill fName & ".xlsm"
newWB.SaveAs Filename:= fName, _
FileFormat:=xlOpenXMLWorkbook, CreateBackup:=False
Workbooks.Open(fName)
End Sub
Alternatively, use the SaveAs method of the Worksheets class:
Sub SaveAs()
Dim fName as String
'Check directory, create if necessary.
If Dir("G:\Load Sheets\" & Year(Now) & "\" & MonthName(Month(Now)) & "\", vbDirectory) = "" Then
If Dir("G:\Load Sheets\" & Year(Now) & "\", vbDirectory) = "" Then
MkDir ("G:\Load Sheets\" & Year(Now) & "\")
End If
MkDir ("G:\Load Sheets\" & Year(Now) & "\" & MonthName(Month(Now)) & "\")
End If
fName = "G:\Load Sheets\" & Year(Now) & "\" & MonthName(Month(Now)) & "\" & Format(Now, "mm-dd-yy") & "x"
If Dir(fName & ".xlsx") <> "" Then Kill fName & ".xlsx"
If Dir(fName & ".xlsm") <> "" Then Kill fName & ".xlsm"
ThisWorkbook.Worksheets("LoadSheet").SaveAs Filename:= fName, _
FileFormat:=xlOpenXMLWorkbook, CreateBackup:=False
ActiveWorkbook.Save
Application.CutCopyMode = False
Workbooks.Open(fName)
End Sub
I've also revised both solutions to avoid the potential error you comment:
If it already exists and is currently open, an error could arise.
I would work with your IT and/or MS support on the specific failure of the .Copy method, though, it's almost certainly a problem with your installation and may result in nastier errors in the future.
I've created this macro in excel that enables a user to copy multiple files from one folder to another. The macros works, it does what it's supposed to do. I just want to add some additional functions to it and I'm not able to make it work. These are the few things that I want to add:
1-check if a file already exists in the destination folder and ask if the user wants to overwrite yes/no. If yes overwrite, If no skip to the next file to be copied.
2-If a file(s) is missing in the source folder the ErrHandler copies the name(s) of the missing file(s) from column A to the M column. The way I did this it works, but it's not how I want it to work. What I want is, if the file name in cell A3, A7, A10 are missing. Those names should be copied to M1, M2, M3 and so on. Instead of copying them to M3, M7, M10
I'm also having 2 other problems:
1-The ErrHandler messagebox it appears more than it should. Once the copy is completed it still shows it 2 more times.
2-The macro it rewrites how the file name is written. For example if the original file name is written in lower case and in a cell I write it in upper case. Once the file is copied it will be written in upper case. I want to keep the original name.
Dim r As Long
Dim SourcePath As String
Dim dstPath As String
Dim myFile As String
SourcePath = Range("F1")
dstPath = Range("F3")
On Error GoTo ErrHandler
For r = 1 To 3000
myFile = Range("A" & r)
FileCopy SourcePath & "\" & myFile, dstPath & "\" & myFile
If Range("A" & r) = "" Then
Exit For
End If
Next r
MsgBox "The file(s) can found in: " & vbNewLine & dstPath, , "COPY COMPLETED"
ErrHandler:
MsgBox "Copy error: " & SourcePath & "\" & myFile & vbNewLine & vbNewLine & _
"File could not be found in the source folder", , "MISSING FILE(S)"
Range("A" & r).Copy Range("M" & r)
Resume Next
End Sub
For the 1st issue, you just need to add an Exit Sub before the ErrHandler: label.
For the second issue, you could try something like:
myFile = dir(SourcePath & "\" & Range("A" & r))
FileCopy SourcePath & "\" & myFile, dstPath & "\" & myFile
This way myFile will contain the original source case.
I have VBA code that creates a backup file (using .SaveCopyAs) every X times my client saves the file. Recently a client ran into the max folder & file path length which seems to be around 220 characters. I'm trying to catch the long file name but Excel/Windows is replacing the long folder names with ~ (tilde) so I can't get the true path length.
How do I get the actual folder/file path string length and prevent Windows from using the "~"?
Sub Backup()
Set awb = ActiveWorkbook
BackupFolder = awb.Path & "\Backups"
BackupFileName = BackupFolder & "\" & awb.Name
BackupFileName = BackupFileName & " " & Format(Now(), "mmddhhmm") & ".xlsm"
'debug.print BackupFileName
'Result: D:\MF\DOCUME~1\LATEST~1\MASTER~1\SUPERL~1\SUPERL~1\Backups\TestLength-07021655.xlsm
'debug.print Len(BackupFileName)
'Result: 83 but the TRUE length is well over 300 characters
PathLen = Len(BackupFileName) 'Result: 83
If PathLen > 215 Then 'This obviously doesn't fire
BackupFolder = GetDesktop & "BidListBackups"
BackupFileName = BackupFolder & "\" & awb.Name
BackupFileName = BackupFileName & " " & sType & Format(Now(), "mmddhhmm") & ".xlsm"
End If
With awb
.SaveCopyAs BackupFileName
End With
If PathLen > 215
MsgBox "Backup file was saved to your desktop", vbokonly
End If
End Sub
See this answer for code that uses the GetLongPathName API. Note that you will need to increase the buffer size from the 165 shown in the code.
I am working on a backup script in VBS that creates a folder and then copies a powerpoint file into the most recently created folder.
Everything works great except MoveFile command at the bottom
Here is what I got so far (the bottom code is most important but just so everyone can understand where I am coming from):
sourceDir = "T:\Team"
destinationDir = "T:\Team\Archive\Archive"
const OverwriteExisting = True
intNum = 1
strDirectory = destinationDir & "_" & replace(date,"/",".") & "_" & intNum
'This checks if the folder exists and if not it will create a folder with the date and increment the folder name incase there are multiple updates in a single day.
if not filesys.FolderExists(destinationDir) then
While filesys.FolderExists(destinationDir & "_" & replace(date,"/",".") & "_" & intNum) = True
intNum = intNum + 1
Wend
Set archivefolder = filesys.CreateFolder(destinationDir & "_" & replace(date,"/",".") & "_" & intNum)
Else
Set archivefolder = filesys.CreateFolder(destinationDir)
Set objFolder = fso.CreateFolder(strDirectory)
End if
Dim thisday, thisdayy, thisdayyy
Today_Date()
' This is the problem code
filesys.MoveFile "T:\Arriva\Project_Organigram_" & thisday & "." & thisdayy & "." & thisdayyy & ".pptm", "destinationDir & "\" & Project_Organigram_" & thisday & "." & thisdayy & "." & thisdayyy & ".pptm"
Function Today_Date()
thisday=Right(Day(Date),2)
thisdayy=Right("0" & Month(Date),2)
thisdayyy=Right("0" & Year(Date),2)
End Function
This results in a folder being created as "T:\Team\Archive\Archive_03.12.2014_1
My goal is to be able to move the file in T:\Team to the dynamically created folder above.
Everything works great until the MoveFile part. The destination is the part throwing a "type mismatch" at the line where I define the strDirectory
I am just learning this type of programming so please let me know if I can provide any further details!
Thank you in advance!
You have a couple syntax errors with your quotes that are cancelling each other out. Change your line to this:
filesys.MoveFile "T:\Team\Project_Organigram_" & thisday & "." & thisdayy & "." & thisdayyy & ".pptm", "destinationDir" & "_" & replace(date,"/",".") & "_" & intNum & "\" & "Project_Organigram_" & thisday & "." & thisdayy & "." & thisdayyy & ".pptm"