I am trying to make the following code work for saving a file name in a certain format. I would like it to save in the folder the file was opened up in. the file would change it's name to a new month name. I have got most of it working, such as directory selection and filename and for it to save, however, if there is already a file with the same name or if someone selects no or cancel it gives an error. I have tried various ways of trying to get around it but now I'm at a loss. I have 2 codes they both are supposed to do the same thing, just variations.
Sub saving1()
' Saves the file under a new name based on the new month date.
Dim NewFilename As String
Dim tempnm
Dim loc ' variable for file location
loc = Application.ThisWorkbook.Path 'loads the file location on the loc variable
MsgBox loc
' creates the file name for saving includes the current path.
NewFilename = loc + "\" + Range("NewFileName").Value & ".xlsm"
'tempmm = Application.GetSaveAsFilename initialfilename
ActiveWorkbook.SaveAs NewFilename, FileFormat:=52
'Application.DisplayAlert = False
'On Error Resume Next 'to omit error when cancel is pressed
' MsgBox "Not saved"
'ActiveWorkbook.Save
'If Err.Number <> 1004 Then 'optional, to confirmed that is not saved
' MsgBox "Not saved"
'End If
' On Error GoTo 0 'to return standard error operation
End Sub
Sub saving()
' Saves the file under a new name based on the new month date.
Dim NewFilename As String
Dim loc ' variable for file location
loc = Application.ThisWorkbook.Path 'loads the file location on the loc variable
' creates the file name for saving includes the current path.
NewFilename = loc + "\" + Range("NewFileName").Value & ".xlsm"
ActiveWorkbook.SaveAs NewFilename, FileFormat:=52
End Sub
I also added message boxes to try see what it is doing during testing. I have also tried the Getsaveasfilename in order to give the user an option to choose his/her own filename and possibly folder. The file location will change once a year.
If Your are looking at overwriting existing file, when there's already a file with same name try below.
NewFilename = loc + "\" + Range("NewFileName").Value & ".xlsm"
Application.DisplayAlerts = False
ActiveWorkbook.SaveAs NewFilename, FileFormat:=52
Application.DisplayAlerts = True
Related
Regarding this question link to rename opened workbook without firstly close it.
The provided answer works greatly ,But I faced cases if new name equal to old name or there is a file with same new name on same folder path.
I modified the code a bit ( as new name will be picked up without user intervention) and added function to check if a file with new name exists or not before rename.
I could not manage to add the incremental number ( added “New” instead).
Now, the code works properly only on first run:
e.g. file name Plan 12-Mar changed to Plan 12-Mar New and Plan 12-Mar deleted , then I closed it.
On second run on the renamed file (Plan 12-Mar New) I got the following message:
file named 'C:\Users\Waleed\Desktop\Plan 12-Mar New.xlsb' already exists in this location. Do you want to replace it?
If I clicked on Yes button , I got this Run-time error '70': Permission denied on this line of code Kill FilePath
Conclusion if I used the code today , if initial name is “Plan 12-Mar” ,then expected actions are (1) save as with rename to “Plan 12-Mar v2” (2) delete the old file “Plan 12-Mar”
and if also I used again today, then expected actions are (1) save as with rename to “Plan 12-Mar v3” (2) delete the old file “Plan 12-Mar v2”.
If I used the code tomorrow, then expected actions are (1) save as with rename to “Plan 13-Mar” (2) delete the old file “Plan 12-Mar v3” , and so on.
Appreciate for yours comments and answers.
Option Explicit
Option Compare Text
Sub Rename_Me()
Dim wb As Workbook: Set wb = ThisWorkbook
Dim DotPosition As Long: DotPosition = InStr(1, wb.Name, ".")
If DotPosition = 0 Then Exit Sub
Dim ibDefault As String: ibDefault = Left(wb.Name, DotPosition - 1)
Dim NewBaseName As String
NewBaseName = "Plan " & Format(Date, "DD-MMM")
If Len(NewBaseName) = 0 Then Exit Sub
Dim FilePath As String: FilePath = wb.FullName
Dim FolderPath As String: FolderPath = wb.path & Application.PathSeparator
Dim Extension As String: Extension = Right(Extension, DotPosition)
Dim ErrNum As Long
On Error Resume Next
If Not Is_File_Exists(wb.FullName) Then
wb.SaveAs FolderPath & NewBaseName & Extension
ErrNum = Err.Number
Else
wb.SaveAs FolderPath & NewBaseName & " New" & Extension 'Instead of "New" ,I v2 ,v3,...
ErrNum = Err.Number
End If
On Error GoTo 0
If ErrNum = 0 Then
Kill FilePath
Else
Kill FilePath
MsgBox "Could not rename.", vbCritical, "Rename Me"
End If
End Sub
And this the function
Function Is_File_Exists(ByVal fName As String) As Boolean
'Returns TRUE if the provided name points to an existing file,
'FALSE if not existing or it's a folder
On Error Resume Next
Is_File_Exists = ((GetAttr(fName) And vbDirectory) <> vbDirectory)
End Function
To allocate a new name, based on the algorithm you try explaining, please use the next function:
Function NewName(strExisting As String) As String
Dim boolToday As Boolean, arrSuffix, arrName, nrSuffix As Long
arrName = Split(strExisting, "."): strExisting = arrName(0)
'check if the root name refers to today date:
If InStr(strExisting, "Plan " & Format(Date, "DD-MMM")) > 0 Then boolToday = True
If boolToday Then
If IsNumeric(Right(strExisting, 1)) Then
arrSuffix = Split(strExisting, " V"): nrSuffix = CLng(arrSuffix(1)) + 1
NewName = arrSuffix(0) & " V" & nrSuffix & "." & arrName(1): Exit Function
Else
NewName = strExisting & " V1." & arrName(1): Exit Function
End If
Else
NewName = "Plan " & Format(Date, "DD-MMM") & "." & arrName(1): Exit Function
End If
End Function
It will add a suffix incrementing the existing number after "V", in case of the name containing current day reference and a new name containing the current date, if a previous one. Then you can delete the workbook with the name sent to the function. It can be tested using the next sub:
Sub testNewName()
Static name As String
If name = "" Then name = "Plan 11-Mar.xlsb"
name = NewName(name): Debug.Print name
End Sub
Run the sub form some times and see the result in Immediate Window.
If, from unknow reasons, a full name identic to the built one can exist, the full name can be checked for its existence and send a message about that before saving As.
New to VBA and have an assignment to create a sub that pastes from one workbook into a new workbook. A requirement for saving the file is that "the folder path be universal so other people can create this folder too". What amendment would I make to the ActiveWorkbook.SaveAs method to fulfill this? Thanks
Sub pasteTable()
Dim formatting As Variant 'create variable to hold formatting2 workbook path
formatting = Application.GetOpenFilename() 'user is prompted and selects path to formatting2 workbook and assigns to formatting variable
Workbooks.Open formatting 'formatting2 workbook is now active
Worksheets("Formatting").Range("B3:R13").Copy 'copies table from formatting2 workbook
Workbooks.Add 'add new workbook
Worksheets(1).Range("B3:R13").Select 'selects range on worksheet of new workbook to paste table
Selection.PasteSpecial xlPasteAll 'pastes table
Columns("B:R").ColumnWidth = 20 'ensures table has proper row and column heights/widths
Rows("3:13").RowHeight = 25
Worksheets(1).Name = "Table Data" 'renames worksheet
ActiveWorkbook.SaveAs "C:\Users\name\Desktop\names Excel Assessment VBA\names Excel Assessment VBA " & Format(Date, "dd/mmm/yyyy"), FileFormat:=xlOpenXMLWorkbookMacroEnabled
'saves workbook according to desired specifications
End Sub
Change your Save line to this:
ActiveWorkbook.SaveAs "C:\Users\" & Environ("Username") & "\Desktop\Excel Assessment VBA\Excel Assessment VBA " & Format(Date, "dd-mmm-yyyy") & ".xlsm", FileFormat:=xlOpenXMLWorkbookMacroEnabled
The Username system variable will adjust depending on the Windows account that is in use. Just make sure each user has those folders existing on their desktop too, or you will get an error. I also removed names from the folder names as i assume you were trying to do something with the username there as well. You can adjust that to your needs.
Your Date format needed to change too as it was including illegal characters.
You also forgot to include a file extension, so I added that as well.
There is a lot going on with that line, including a lot of mistakes, so you are going to have to play with it a bit until you get exactly what you need. You may want to simplify it a bit until you get the hang of all those things.
I think you have to add some more checks
The script expects the name of the tool-path-folder as constant ToolFolder.
Plus a second constant ToolBaseFolder that could be set to the parent-path `ToolFolder, e.g. a network path. If the const is empty, users desktop will be used.
If this path does not yet exist it will be created.
Option Explicit
Private Const ToolBaseFolder As String = "" 'if ToolBaseFolder is an empty string desktop will be used instead
Private Const ToolFolder As String = "MyNameForToolFolder"
Public Sub testWbToToolFolder()
'this is just for testing
Dim wb As Workbook: Set wb = ActiveWorkbook
saveWbToToolFolder wb, "test.xlsx"
End Sub
Public Sub saveWbToToolFolder(wb As Workbook, filename As String)
'you don't need this sub - but have the same code line in your main routine
wb.SaveAs getToolFolder & filename
End Sub
Public Function getToolFolder() As String
'this returns the toolfolder e.g. C:\Users\xyz\Desktop\MyNameForToolFolder
Dim basepath As String
basepath = ToolBaseFolder & "\"
If existsFolder(basepath) = False Then
If LenB(ToolBaseFolder) > 0 Then
MsgBox ToolBaseFolder & " does not exist." & vbCrLf & _
"File will be saved to " & ToolFolder & " on desktop ", vbExclamation
End If
basepath = getDesktopFolderOfUser
End If
Dim fullpath As String
fullpath = basepath & ToolFolder & "\"
If existsFolder(fullpath) = False Then
makeFolder fullpath
End If
getToolFolder = fullpath
End Function
Private Function existsFolder(path As String) As Boolean
If Len(path) < 2 Then Exit Function 'can't be a valid folder
existsFolder = LenB(Dir(path, vbDirectory)) > 0
End Function
Private Function getDesktopFolderOfUser() As String
getDesktopFolderOfUser = CreateObject("WScript.Shell").SpecialFolders("Desktop") & "\"
End Function
Private Function makeFolder(path As String)
'https://stackoverflow.com/a/26934834/16578424 plus comment from rayzinnz
CreateObject("WScript.Shell").Run "cmd /c mkdir """ & path & """", 0, True
End Function
The code below shows my save macro. Right now it saves the current workbook in a specific file path with the current workbook name. How can I add today's date in the current workbook name? So it saves to the designated file path with the current workbook name and today's date on the end?
Sub Save_Workbook()
ActiveWorkbook.SaveAs "H:\HR\Cole G\Timehseet Test Path\" & ActiveWorkbook.Name
End Sub
First off, .Name may or may not include a file extension, depending on if the file has been saved or not. (eg. "Test.xls" or "Book2")
Const Path = "H:\HR\Cole G\Timehseet Test Path\"
Dim Pos as Long
Pos = InStrRev(ActiveWorkbook.Name, ".") - 1
' If there wasn't a ".", then the file doesn't have an extension and Pos = -1
If Pos < 0 then Pos = Len(ActiveWorkbook.Name)
' Now put everything together, including the file extension...
ActiveWorkbook.SaveAs Path & Left(ActiveWorkbook.Name,Pos) & Format(Now, "yyyy-mm-dd") & Mid(ActiveWorkbook.Name,Pos+1)
This should be reliable regardless of file extension (even if there is no file extension!), as long as you're using common Excel file types. If you're opening weird .HTML files it may need some tweaking.
Sub Save_Workbook()
Dim fileNameWithoutExtension as String
fileNameWithoutExtension = getFileNameWithoutExtension(ActiveWorkbook)
ActiveWorkbook.SaveAs "H:\HR\Cole G\Timehseet Test Path\" & fileNameWithoutExtension & Format(Date, "YYYY-MM-DD"), FileFormat:=ActiveWorkbook.FileFormat
End Sub
Function getFileNameWithoutExtension(wb As Workbook)
Dim baseName As String
If (wb.Name = wb.FullName) Then
' This handles files that have not been saved, which won't have an extension
baseName = wb.Name
GoTo EarlyExit
End If
Select Case wb.FileFormat
Case xlOpenXMLAddIn, xlOpenXMLStrictWorkbook, xlOpenXMLTemplate, xlOpenXMLTemplateMacroEnabled, _
xlOpenXMLWorkbook, xlWorkbookDefault
' These all have a 4-character extension
baseName = Left(wb.Name, Len(wb.Name) - 5)
Case Else
' almost every other file type is a 3-character extension,
' but modify if needed based on this enumeration:
' https://msdn.microsoft.com/en-us/vba/excel-vba/articles/xlfileformat-enumeration-excel
baseName = Left(wb.Name, Len(wb.Name) - 4)
End Select
EarlyExit:
getFileNameWithoutExtension = baseName
End Function
I used some code from Close an opened PDF after opening it using FollowHyperlink to create the following code to open a pdf file and rename it. The code runs fine but only if I break execution at MsgBox "Break Here" and step into it with the F8 key. Any ideas on why it won't execute automatically?
Sub OpenPDF()
'Opens PDF Scaned file & saves it to another folder
'***ErrorHandler***
On Error Resume Next
'***Declare Objects****
Dim objectWMI As Object
Dim objectProcess As Object
Dim objectProcesses As Object
Dim Path As String
Dim MyDir As String
'***Opens a new workbook if there are no active workbooks***
'***There must be an active workbook for FollowHyperlink to function***
nowbs = Application.Workbooks.Count
If nowbs = 1 Then
Application.Workbooks.Add
Else
End If
'***Saves current Excel path
MyDir = CurDir
'***Sets path to Ricoh Scans
PDFDir = "S:\Ricoh Scans"
ChDir PDFDir
'***Gets filename for PDF scan
Path = Application.GetOpenFilename(filefilter:="PDF file (*.pdf), *.pdf")
'***Opens PDF file***
ActiveWorkbook.FollowHyperlink Path
'***Sets Excel as active application
AppActivate "Microsoft Excel"
'***Prompts for PO number****
MyPONum = InputBox("Enter PO Number", "PO Editor", "30500")
'***If user selects Cancel on inputbox then xl closes Acrobat and exits sub
If MyPONum = vbNullString Then
GoTo EndAll
Else
End If
'***Replaces scanned filename with inputbox filename
PathLen = Len(Path)
OldName = Mid(Path, 16, PathLen - 19)
NewName = "S:\Materials Management\Purchase Orders\PO " & MyPONum & ".pdf"
EndAll:
'***Set Objects***
Set objectWMI = GetObject("winmgmts://.")
Set objectProcesses = objectWMI.ExecQuery("SELECT * FROM Win32_Process WHERE Name = 'Acrobat.exe'") '< Change if you need be ** Was AcroRd32.exe**
'
'
'Code executes fine up to here but must Ctrl + Break at this line
'and F8 step thru balance of code or it will not work
'
'
MsgBox "Break Here"
'***Terminate all Open PDFs***
For Each objectProcess In objectProcesses
Call objectProcess.Terminate
Next
'***Clean Up***
Set objectProcesses = Nothing
Set objectWMI = Nothing
'***Renames scanned file and moves it to Materials Management folder***
Name Path As NewName
'***Resets current directory
ChDir MyDir
End Sub
Thanks to all for your input. I'm not a programmer and as I said I used code that had been posted elsewhere on this site. It was a timing issue and this edit works.
'***Terminate all Open PDFs***
For Each objectProcess In objectProcesses
objectProcess.Terminate
Next
'***Clean Up***
Set objectProcesses = Nothing
Set objectWMI = Nothing
'***************
Application.Wait (Now + TimeValue("00:00:02"))
'***Renames scanned file and moves it to Materials Management folder***
Name Path As NewName
'***Resets current directory
ChDir MyDir
End Sub
I need code that saves incrementally numbered versions of a file based on whether similarly named files already exist in a specified folder.
For example,
Check for the prescence of currently open file, say named
"Inv_Dec_2015.xlsx" in a folder named "Reports".
If file exists, check for "Inv_Dec_2015_v1.xlsx" in "Reports".
If file exists, check for "Inv_Dec_2015_v2.xlsx" in "Reports".
If file exists, check for "Inv_Dec_2015_v3.xlsx" in "Reports".
If file does NOT exist, Save currently open file as "Inv_Dec_2015_v3.xlsx"
and so on till any number of versions......
I found the following two pieces of code on Ron de Bruin's website that can be used for something like this and modified it a bit to my purpose, but I don't know how use it to check for pre-existing files.
Would deeply appreciate any help with this.
Sub Rename_Store_Wbk()
Dim sPath As String
' Enter the path at which file is to be stored
sPath = ActiveSheet.Range("K1").Value & ActiveSheet.Range("K2").Value & ".xlsx"
' Check whether the file already exists by calling the FileExist function
If FileExist(sPath) = False Then
ActiveWorkbook.SaveAs Filename:=sPath, _
FileFormat:=xlOpenXMLWorkbook, CreateBackup:=False
End If
End Sub
Function FileExist(FilePath As String) As Boolean
Dim TestStr As String
'Test File Path (ie "C:\Users\Chris\Reports\Inv_Dec_2015.xlsm")
On Error Resume Next
TestStr = Dir(FilePath)
On Error GoTo 0
'Determine if File exists
If TestStr = "" Then
FileExist = False
Else
FileExist = True
End If
End Function
See if the loop I added in here works for you:
Sub Rename_Store_Wbk()
Dim sPath As String
' Enter the path at which file is to be stored
sPath = ActiveSheet.Range("K1").Value & ActiveSheet.Range("K2").Value & ".xlsx"
If Not FileExists(sPath) Then
i = 1
Do
sPath = Left(sPath, Len(sPath) - 5) & "_v" & i & ".xlsx"
i = i + 1
Loop Until FileExists(sPath)
End If
ActiveWorkbook.SaveAs Filename:=sPath, _
FileFormat:=xlOpenXMLWorkbook, CreateBackup:=False
End Sub