I am trying to save a file but before that I am checking if the same name file already exists in the same folder, if it's there, I rename the old existing file (add a timestamp to it's name) and move it to a different folder location. For renaming I am using "Name" method but it's showing error.
I have already tested that a file with same name already exists.The timestamp to be added is also coming up. Below is the code.
Dim Test As String
On Error Resume Next
Test = Dir(ThisWorkbook.Sheets("Sheet1").Range("B5").Text)
On Error GoTo 0
If Test = "" Then
fileexist = False
Else
fileexist = True
Timestamp = CStr(FileDateTime(ThisWorkbook.Sheets("Sheet1").Range("B5").Text))
Newname = Left((ThisWorkbook.Sheets("Sheet1").Range("B5").Text), Len((ThisWorkbook.Sheets("Sheet1").Range("B5").Text)) - 5) & Timestamp & ".xlsx"
Name (ThisWorkbook.Sheets("Sheet1").Range("B5").Text) As Newname
'*** Just this last above statment is giving error
End if
The file already exists so why is the Name method giving error? Thanks in advance for any help.
Maybe give this a try :
Sub tryme()
Dim test As String
On Error Resume Next
test = Dir(ThisWorkbook.Path & "\" & ThisWorkbook.Sheets("Sheet1").Range("B5").Text)
On Error GoTo 0
If test = "" Then
fileexist = False
Else
fileexist = True
Timestamp = CStr(FileDateTime(ThisWorkbook.Path & "\" & ThisWorkbook.Sheets("Sheet1").Range("B5").Text))
newname = Left((ThisWorkbook.Sheets("Sheet1").Range("B5").Text), Len((ThisWorkbook.Sheets("Sheet1").Range("B5").Text)) - 5) & Format(Timestamp, "ddmmmyyyy") & ".xlsm"
ThisWorkbook.SaveAs FileName:=ThisWorkbook.Path & "\" & newname
End If
End Sub
If the path is in B5 then just do as follow :
Dim Test As String
On Error Resume Next
Test = Dir(ThisWorkbook.Sheets("Sheet1").Range("B5").Text)
On Error GoTo 0
If Test = "" Then
fileexist = False
Else
fileexist = True
Timestamp = CStr(FileDateTime(ThisWorkbook.Sheets("Sheet1").Range("B5").Text))
Newname = Left((ThisWorkbook.Sheets("Sheet1").Range("B5").Text), Len((ThisWorkbook.Sheets("Sheet1").Range("B5").Text)) - 5) & Format(Timestamp, "ddmmmyyyy") & ".xlsx"
'Name (ThisWorkbook.Sheets("Sheet1").Range("B5").Text) As Newname
ThisWorkbook.SaveAs FileName:=ThisWorkbook.Path & "\" & Newname
End if
Related
I'm trying to get a macro to work as a version history tool. I think I'm using basic methods here and there might be better ones out there but I think it's doable nonetheless. The error I get is "Subscript out of range". The culpript is the second to last line of my code, which is where I save a copy of the file. So this is my code:
Sub Historian()
Dim filePath As String
Static counter As Integer
Dim fileName As String
filePath = "A:\Downloads A\Ex_Files_Learning_VBA_Excel\Exercise Files\Ch05\WbkBackup"
For counter = 0 To 10
Workbooks.Open (filePath & counter)
On Error GoTo Handler:
Next counter
MsgBox ("counter has reached 10")
Exit Sub
Handler:
ThisWorkbook.Activate
fileName = ThisWorkbook.FullName
Workbooks(fileName).SaveCopyAs fileName:=(filePath & counter)
MsgBox ("ok, last version was: " & counter)
End Sub
Workbooks(filename) do not take the filename full path as argument, only the filename.
Change Workbooks(filename) to ThisWorkbook as suggested by Warcupine
To improve your code, I would suggest you not to test the opening of Workbook. This is long and then you have to close the workbooks you opened...
Instead you could use the Dir() function:
Check if the file exists using VBA
On Error GoTo Handler
should be placed before
Workbooks.Open (filePath & counter)
which should be:
Workbooks.Open (filePath & "\" & split(Thisworkbook.Name, ".")(0) & counter & "." & split(Thisworkbook.Name, ".")(1))
In fact, your code should look in this way:
Sub Historian()
Dim filePath As String, fileName As String, strExt As String
Static counter As Long
filePath = "C:\Teste VBA Excel\PROG BACKUP" ' "A:\Downloads A\Ex_Files_Learning_VBA_Excel\Exercise Files\Ch05\WbkBackup"
fileName = Split(ThisWorkbook.Name, ".")(0)
strExt = Split(ThisWorkbook.Name, ".")(1)
For counter = 0 To 10
On Error GoTo Handler:
Workbooks.Open (filePath & "\" & fileName & counter & "." & strExt)
Next counter
MsgBox ("counter has reached 10")
Exit Sub
Handler:
ThisWorkbook.SaveCopyAs fileName:=(filePath & "\" & fileName & counter & "." & strExt)
MsgBox ("ok, last version was: " & counter)
End Sub
But I think that checking the existing of the workbook by opening it, is not so appropriate way. I would suggest you to replace
On Error GoTo Handler:
Workbooks.Open (filePath & "\" & fileName & counter & "." & strExt)
with
If Dir(filePath & "\" & fileName & counter & "." & strExt) = "" Then GoTo Handler
Trying to use the DIR function in a Macro to determine whether a folder exists. Have found the following code
Function FileOrFolderExistsOnMac(FileOrFolderstr As String) As Boolean
Ron de Bruin : 1-Feb-2019
Function to test whether a file or folder exist on a Mac in office 2011 and up
'Uses AppleScript to avoid the problem with long names in Office 2011,
'limit is max 32 characters including the extension in 2011.
Dim ScriptToCheckFileFolder As String
Dim TestStr As String
If Val(Application.Version) < 15 Then
ScriptToCheckFileFolder = "tell application " & Chr(34) & "System Events" & Chr(34) & _
"to return exists disk item (" & Chr(34) & FileOrFolderstr & Chr(34) & " as string)"
FileOrFolderExistsOnMac = MacScript(ScriptToCheckFileFolder)
Else
On Error Resume Next
TestStr = Dir(FileOrFolderstr & "*", vbDirectory)
On Error GoTo 0
If Not TestStr = vbNullString Then FileOrFolderExistsOnMac = True
End If
End Function
from
https://www.rondebruin.nl/win/s9/win003.htm
However, when the folder in the path location is empty, the function determines that the path directory does not exist.
Thank you for the post, it helped me identify the source of my problem.
I modified my often-used function to account for this quirk.
Here's a modified function that should work for empty folders (works on Windows, not tested on Macs).
Function directoryExists(ByVal dirPath As String) As Boolean
'amy#logicallytech.com
'7/15/2022
directoryExists = (Dir(dirPath) <> "")
If directoryExists Then Exit Function
'If folder is empty, above will show it does not exist, so just to confirm...
Dim strParentFolder As String
Dim strSubFolder As String
Dim myfso As Object
Dim parentFolder As Object
Dim subFolder As Object
If InStr(dirPath, "\") > 0 Then
If Right(dirPath, 1) = "\" Then dirPath = Left(dirPath, Len(dirPath) - 1)
strParentFolder = Left(dirPath, InStrRev(dirPath, "\", , vbTextCompare))
strSubFolder = Right(dirPath, Len(dirPath) - InStrRev(dirPath, "\", , vbTextCompare))
ElseIf InStr(dirPath, "/") > 0 Then
If Right(dirPath, 1) = "/" Then dirPath = Left(dirPath, Len(dirPath) - 1)
strParentFolder = Left(dirPath, InStrRev(dirPath, "/", , vbTextCompare))
strSubFolder = Right(dirPath, Len(dirPath) - InStrRev(dirPath, "/", , vbTextCompare))
End If
Set myfso = CreateObject("Scripting.FileSystemObject")
Set parentFolder = myfso.GetFolder(strParentFolder)
For Each subFolder In parentFolder.SubFolders
If LCase(Trim(subFolder.Name)) = LCase(Trim(strSubFolder)) Then
directoryExists = True
GoTo CleanUp
End If
Next subFolder
CleanUp:
Set subFolder = Nothing
Set parentFolder = Nothing
Set myfso = Nothing
End Function
I need to save my excel file using a macro and I am making use of an old macro I made a while ago - which worked just fine. But now, I am getting an error which I don't seem to understand all to well.
Code:
Option Explicit
Sub SaveFile()
Dim strDir As String, saveDate As String, userMachine As String, Filename As String, yearDate As String, monthDate As String, filePath As String
Dim ws1 As Workbook
Set ws1 = Workbooks("Template.xlsm")
Application.DisplayAlerts = False
saveDate = "01/02/2019"
yearDate = Year(saveDate)
monthDate = Format(saveDate, "MMMM")
saveDate = Format(saveDate, "dd-mm-yyyy")
userMachine = "User - 12345"
strDir = "C:\user12345\desktop\Final Results\" & yearDate & "\" & monthDate & "\" & Format(saveDate, "dd-mm-yyyy") & "\"
filePath = ""
Filename = userMachine & " - " & saveDate & ".xlsx"
filePath = Dir(strDir & Filename)
If Dir(strDir, vbDirectory) = "" Then
MkDir strDir
If filePath = "" Then
ws1.SaveAs Filename:=filePath, FileFormat:=51, CreateBackup:=False
Else
MsgBox filePath & " Execution File Exists"
End If
Else
If filePath = "" Then
ws1.SaveAs Filename:=filePath, FileFormat:=51, CreateBackup:=False
Else
MsgBox filePath & " Execution File Exists"
End If
End If
End Sub
The error is on this line filePath = Dir(strDir & Filename) and the error is:
Bad File Name or Number
As far as I can see, my name for the file meets the requirements to save it so I am at a total loss here.
The original code I had was this:
strDir = "C:\username\desktop\" & Format(DateAdd("d", -1, Date), "dd_mm_YY") & "\"
FilePath = Dir(strDir & "myFile.xlsx")
Bad File Name or Number means that the string you are using to save the file is not valid.
You could replace the hardcoded string to your desktop with a relative reference from a function, such as:
Function getDeskTopPath() As String
'Get Desktop path as string
'Command can be exchanged for other information... see list below
'AllUsersDesktop
'AllUsersStartMenu
'AllUsersPrograms
'AllUsersStartup
'Desktop
'Favorites
'Fonts
'MyDocuments
'NetHood
'PrintHood
'Programs
'Recent
'SendTo
'StartMenu
'Startup
'Templates
Dim oShell As Object
Set oShell = CreateObject("Wscript.Shell")
getDeskTopPath = oShell.SpecialFolders("Desktop")
Set oShell = Nothing
End Function
I have code for creating new folder on users desktop. I would like to add more functionality to it. Before creating new folder it should check if folder already exists (it is doing it right now). Then if there is folder with the same name, code should create new folder with next available number 1,2,3...
So if there is already folder with name "T34-23, Quotation", code should create folder named "T34-23, Quotation 1". If there is "T34-23, Quotation 1" then create "T34-23, Quotation 2" etc.
Sub MakeMyFolder()
Dim fdObj As Object
Application.ScreenUpdating = False
Set fdObj = CreateObject("Scripting.FileSystemObject")
If fdObj.FolderExists(Environ$("USERPROFILE") & "\Desktop\" & ThisWorkbook.Sheets("Other Data").Range("AK2").Value & ", " & _
ThisWorkbook.Sheets("Other Data").Range("AK7").Value) Then
'MsgBox "Found it.", vbInformation, "Excel"
Else
fdObj.CreateFolder (Environ$("USERPROFILE") & "\Desktop\" & ThisWorkbook.Sheets("Other Data").Range("AK2").Value & ", " & _
ThisWorkbook.Sheets("Other Data").Range("AK7").Value)
'MsgBox "It has been created.", vbInformation, "Excel"
End If
Set fdObj = Nothing
Application.ScreenUpdating = True
End Sub
As #urderboy suggests, you should use some variables in this.
Function CheckAndSuffixFolder(strPathToCheck As String, _
Optional blnCreateFolder As Boolean = False) As String
Dim f As New Scripting.FileSystemObject
Dim l As Long
Dim s As String
s = strPathToCheck
l = 1
Do While f.FolderExists(s)
l = l + 1
s = strPathToCheck & l
Loop
If blnCreateFolder Then f.CreateFolder s
CheckAndSuffixFolder = s
End Function
Calling like so, I have Folder, FOlder1 and FOlder2.
CheckAndSuffixFolder("C:\Workspace\Training\Folder") Gives me Folder3
Can't test it out now, but I'm thinking the solution will require you to loop through numbers until there is one that value that returns False. If the file check returns True then the file exists increment up until you get to the number needed. untested code:
Dim createFile Boolean: createFile = False
Dim i as Integer: i = 1
Do while createFile = False
Dim strDir As String
strDir = folderDir & "T34-23, Quotation" & i & "\"
If Dir(strDir, vbDirectory) = "" Then
MkDir strDir
createFile = True
Else
i = i+1
End If
wend
Hi I am trying to create a code that checks for part of a file name and then will save the document with a increment of that file name, for example the below is creating a file name then using left to get just the part I want to check if it exists in any form but how do I check if a filename contains that info
TicketNumber = "0"
FileE = 1
UName = Range("C1")
On Error GoTo ErrorDocumentName
With New FileSystemObject
Do While FileE = 1
FileName = "REM" & TicketNumber & " - " & UName & ".xlsm"
Pos = InStr(FileName, "-")
LeftFN = Left(FileName, Pos - 2)
LeftFP = ThisWorkbook.Path & "\" & LeftFN
FileP = ThisWorkbook.Path & "\" & FileName
DisplayName = "REM" & TicketNumber
If .FileExists(LeftFP & WildC) Then
TicketNumber = TicketNumber + 1
ElseIf Not .FileExists(LeftFP & WildC) Then
FileE = 0
End If
Loop
End With
On Error GoTo ErrorRunning
Application.DisplayAlerts = False
ActiveWorkbook.SaveAs FileName:=FileP, FileFormat:=xlOpenXMLWorkbookMacroEnabled, CreateBackup:=False
ActiveSheet.Name = "Incident"
ActiveWorkbook.Save
Application.DisplayAlerts = True
Exit Sub