I have a pull down menu of companies that is populated by a list on another sheet. Three columns, Company, Job #, and Part Number.
When a job is created I need a folder for said company and a sub-folder for said Part Number.
If you go down the path it would look like:
C:\Images\Company Name\Part Number\
If either company name or Part number exists don't create, or overwrite the old one. Just go to next step. So if both folders exist nothing happens, if one or both don't exist create as required.
Another question is there a way to make it so it works on Macs and PCs the same?
Another simple version working on PC:
Sub CreateDir(strPath As String)
Dim elm As Variant
Dim strCheckPath As String
strCheckPath = ""
For Each elm In Split(strPath, "\")
strCheckPath = strCheckPath & elm & "\"
If Len(Dir(strCheckPath, vbDirectory)) = 0 Then MkDir strCheckPath
Next
End Sub
One sub and two functions. The sub builds your path and use the functions to check if the path exists and create if not. If the full path exists already, it will just pass on by.
This will work on PC, but you will have to check what needs to be modified to work on Mac as well.
'requires reference to Microsoft Scripting Runtime
Sub MakeFolder()
Dim strComp As String, strPart As String, strPath As String
strComp = Range("A1") ' assumes company name in A1
strPart = CleanName(Range("C1")) ' assumes part in C1
strPath = "C:\Images\"
If Not FolderExists(strPath & strComp) Then
'company doesn't exist, so create full path
FolderCreate strPath & strComp & "\" & strPart
Else
'company does exist, but does part folder
If Not FolderExists(strPath & strComp & "\" & strPart) Then
FolderCreate strPath & strComp & "\" & strPart
End If
End If
End Sub
Function FolderCreate(ByVal path As String) As Boolean
FolderCreate = True
Dim fso As New FileSystemObject
If Functions.FolderExists(path) Then
Exit Function
Else
On Error GoTo DeadInTheWater
fso.CreateFolder path ' could there be any error with this, like if the path is really screwed up?
Exit Function
End If
DeadInTheWater:
MsgBox "A folder could not be created for the following path: " & path & ". Check the path name and try again."
FolderCreate = False
Exit Function
End Function
Function FolderExists(ByVal path As String) As Boolean
FolderExists = False
Dim fso As New FileSystemObject
If fso.FolderExists(path) Then FolderExists = True
End Function
Function CleanName(strName as String) as String
'will clean part # name so it can be made into valid folder name
'may need to add more lines to get rid of other characters
CleanName = Replace(strName, "/","")
CleanName = Replace(CleanName, "*","")
etc...
End Function
I found a much better way of doing the same, less code, much more efficient. Note that the """" is to quote the path in case it contains blanks in a folder name. Command line mkdir creates any intermediary folder if necessary to make the whole path exist.
If Dir(YourPath, vbDirectory) = "" Then
Shell ("cmd /c mkdir """ & YourPath & """")
End If
Private Sub CommandButton1_Click()
Dim fso As Object
Dim fldrname As String
Dim fldrpath As String
Set fso = CreateObject("scripting.filesystemobject")
fldrname = Format(Now(), "dd-mm-yyyy")
fldrpath = "C:\Temp\" & fldrname
If Not fso.FolderExists(fldrpath) Then
fso.createfolder (fldrpath)
End If
End Sub
There are some good answers on here, so I will just add some process improvements. A better way of determining if the folder exists (does not use FileSystemObjects, which not all computers are allowed to use):
Function FolderExists(FolderPath As String) As Boolean
FolderExists = True
On Error Resume Next
ChDir FolderPath
If Err <> 0 Then FolderExists = False
On Error GoTo 0
End Function
Likewise,
Function FileExists(FileName As String) As Boolean
If Dir(FileName) <> "" Then FileExists = True Else FileExists = False
EndFunction
Function MkDir(ByVal strDir As String)
Dim fso: Set fso = CreateObject("Scripting.FileSystemObject")
If Not fso.FolderExists(strDir) Then
' create parent folder if not exist (recursive)
MkDir (fso.GetParentFolderName(strDir))
' doesn't exist, so create the folder
fso.CreateFolder strDir
End If
End Function
This works like a charm in AutoCad VBA and I grabbed it from an excel forum. I don't know why you all make it so complicated?
FREQUENTLY ASKED QUESTIONS
Question: I'm not sure if a particular directory exists already. If it doesn't exist, I'd like to create it using VBA code. How can I do this?
Answer: You can test to see if a directory exists using the VBA code below:
(Quotes below are omitted to avoid confusion of programming code)
If Len(Dir("c:\TOTN\Excel\Examples", vbDirectory)) = 0 Then
MkDir "c:\TOTN\Excel\Examples"
End If
http://www.techonthenet.com/excel/formulas/mkdir.php
For those looking for a cross-platform way that works on both Windows and Mac, the following works:
Sub CreateDir(strPath As String)
Dim elm As Variant
Dim strCheckPath As String
strCheckPath = ""
For Each elm In Split(strPath, Application.PathSeparator)
strCheckPath = strCheckPath & elm & Application.PathSeparator
If (Len(strCheckPath) > 1 And Not FolderExists(strCheckPath)) Then
MkDir strCheckPath
End If
Next
End Sub
Function FolderExists(FolderPath As String) As Boolean
FolderExists = True
On Error Resume Next
ChDir FolderPath
If Err <> 0 Then FolderExists = False
On Error GoTo 0
End Function
Never tried with non Windows systems, but here's the one I have in my library, pretty easy to use. No special library reference required.
Function CreateFolder(ByVal sPath As String) As Boolean
'by Patrick Honorez - www.idevlop.com
'create full sPath at once, if required
'returns False if folder does not exist and could NOT be created, True otherwise
'sample usage: If CreateFolder("C:\toto\test\test") Then debug.print "OK"
'updated 20130422 to handle UNC paths correctly ("\\MyServer\MyShare\MyFolder")
Dim fs As Object
Dim FolderArray
Dim Folder As String, i As Integer, sShare As String
If Right(sPath, 1) = "\" Then sPath = Left(sPath, Len(sPath) - 1)
Set fs = CreateObject("Scripting.FileSystemObject")
'UNC path ? change 3 "\" into 3 "#"
If sPath Like "\\*\*" Then
sPath = Replace(sPath, "\", "#", 1, 3)
End If
'now split
FolderArray = Split(sPath, "\")
'then set back the # into \ in item 0 of array
FolderArray(0) = Replace(FolderArray(0), "#", "\", 1, 3)
On Error GoTo hell
'start from root to end, creating what needs to be
For i = 0 To UBound(FolderArray) Step 1
Folder = Folder & FolderArray(i) & "\"
If Not fs.FolderExists(Folder) Then
fs.CreateFolder (Folder)
End If
Next
CreateFolder = True
hell:
End Function
Here's short sub without error handling that creates subdirectories:
Public Function CreateSubDirs(ByVal vstrPath As String)
Dim marrPath() As String
Dim mint As Integer
marrPath = Split(vstrPath, "\")
vstrPath = marrPath(0) & "\"
For mint = 1 To UBound(marrPath) 'walk down directory tree until not exists
If (Dir(vstrPath, vbDirectory) = "") Then Exit For
vstrPath = vstrPath & marrPath(mint) & "\"
Next mint
MkDir vstrPath
For mint = mint To UBound(marrPath) 'create directories
vstrPath = vstrPath & marrPath(mint) & "\"
MkDir vstrPath
Next mint
End Function
I know this has been answered and there were many good answers already, but for people who come here and look for a solution I could post what I have settled with eventually.
The following code handles both paths to a drive (like "C:\Users...") and to a server address (style: "\Server\Path.."), it takes a path as an argument and automatically strips any file names from it (use "\" at the end if it's already a directory path) and it returns false if for whatever reason the folder could not be created. Oh yes, it also creates sub-sub-sub-directories, if this was requested.
Public Function CreatePathTo(path As String) As Boolean
Dim sect() As String ' path sections
Dim reserve As Integer ' number of path sections that should be left untouched
Dim cPath As String ' temp path
Dim pos As Integer ' position in path
Dim lastDir As Integer ' the last valid path length
Dim i As Integer ' loop var
' unless it all works fine, assume it didn't work:
CreatePathTo = False
' trim any file name and the trailing path separator at the end:
path = Left(path, InStrRev(path, Application.PathSeparator) - 1)
' split the path into directory names
sect = Split(path, "\")
' what kind of path is it?
If (UBound(sect) < 2) Then ' illegal path
Exit Function
ElseIf (InStr(sect(0), ":") = 2) Then
reserve = 0 ' only drive name is reserved
ElseIf (sect(0) = vbNullString) And (sect(1) = vbNullString) Then
reserve = 2 ' server-path - reserve "\\Server\"
Else ' unknown type
Exit Function
End If
' check backwards from where the path is missing:
lastDir = -1
For pos = UBound(sect) To reserve Step -1
' build the path:
cPath = vbNullString
For i = 0 To pos
cPath = cPath & sect(i) & Application.PathSeparator
Next ' i
' check if this path exists:
If (Dir(cPath, vbDirectory) <> vbNullString) Then
lastDir = pos
Exit For
End If
Next ' pos
' create subdirectories from that point onwards:
On Error GoTo Error01
For pos = lastDir + 1 To UBound(sect)
' build the path:
cPath = vbNullString
For i = 0 To pos
cPath = cPath & sect(i) & Application.PathSeparator
Next ' i
' create the directory:
MkDir cPath
Next ' pos
CreatePathTo = True
Exit Function
Error01:
End Function
I hope someone may find this useful. Enjoy! :-)
This is a recursive version that works with letter drives as well as UNC. I used the error catching to implement it but if anyone can do one without, I would be interested to see it. This approach works from the branches to the root so it will be somewhat usable when you don't have permissions in the root and lower parts of the directory tree.
' Reverse create directory path. This will create the directory tree from the top down to the root.
' Useful when working on network drives where you may not have access to the directories close to the root
Sub RevCreateDir(strCheckPath As String)
On Error GoTo goUpOneDir:
If Len(Dir(strCheckPath, vbDirectory)) = 0 And Len(strCheckPath) > 2 Then
MkDir strCheckPath
End If
Exit Sub
' Only go up the tree if error code Path not found (76).
goUpOneDir:
If Err.Number = 76 Then
Call RevCreateDir(Left(strCheckPath, InStrRev(strCheckPath, "\") - 1))
Call RevCreateDir(strCheckPath)
End If
End Sub
Sub FolderCreate()
MkDir "C:\Test"
End Sub
Sub MakeAllPath(ByVal PS$)
Dim PP$
If PS <> "" Then
' chop any end name
PP = Left(PS, InStrRev(PS, "\") - 1)
' if not there so build it
If Dir(PP, vbDirectory) = "" Then
MakeAllPath Left(PP, InStrRev(PS, "\") - 1)
' if not back to drive then build on what is there
If Right(PP, 1) <> ":" Then MkDir PP
End If
End If
End Sub
'Martins loop version above is better than MY recursive version
'so improve to below
Sub MakeAllDir(PathS$)
' format "K:\firstfold\secf\fold3"
If Dir(PathS) = vbNullString Then
' else do not bother
Dim LI&, MYPath$, BuildPath$, PathStrArray$()
PathStrArray = Split(PathS, "\")
BuildPath = PathStrArray(0) & "\" '
If Dir(BuildPath) = vbNullString Then
' trap problem of no drive :\ path given
If vbYes = MsgBox(PathStrArray(0) & "< not there for >" & PathS & " try to append to " & CurDir, vbYesNo) Then
BuildPath = CurDir & "\"
Else
Exit Sub
End If
End If
'
' loop through required folders
'
For LI = 1 To UBound(PathStrArray)
BuildPath = BuildPath & PathStrArray(LI) & "\"
If Dir(BuildPath, vbDirectory) = vbNullString Then MkDir BuildPath
Next LI
End If
' was already there
End Sub
' use like
'MakeAllDir "K:\bil\joan\Johno"
'MakeAllDir "K:\bil\joan\Fredso"
'MakeAllDir "K:\bil\tom\wattom"
'MakeAllDir "K:\bil\herb\watherb"
'MakeAllDir "K:\bil\herb\Jim"
'MakeAllDir "bil\joan\wat" ' default drive
Related
Using 2010 Excel VBA - I need to use look up the image/pdf with the Branch Code as a part of its name at "C:\ECB Test\ECB IR COPY" and paste it at "C:\ECB Test\" RO if it exists. If it doesn't, the program needs to highlight the Branch Code.
(File Name Examples: 28-Kochi-ecb-sdwan completed.pdf, 23 eCB Kozhikode completed.pdf/0036.jpeg)
Having done this manually twice for two other excel sheets (4k+ cells), I decided to Frankenstein a module together and, well, it does not work and I have no idea why.
Sub Sort()
Const SRC_PATH As String = "C:\ECB Test\ECB IR COPY"
Const DEST_PATH As String = "C:\ECB Test"
Dim Row_Number As Integer
Dim fso As Object
Set fso = VBA.CreateObject("Scripting.FileSystemObject")
Dim Folder_Name As String
Dim Branch_Code As String
Dim Final_Path As Variant
Dim File As String
For Row_Number = 3 To 2465
Branch_Code = Worksheets("WAN RFP").Cells(Row_Number, 2)
Folder_Name = Worksheets("WAN RFP").Cells(Row_Number, 5)
On Error Resume Next
File = Dir(SRC_PATH & "\*" & Branch_Code & "*")
Final_Path = Dir(DEST_PATH & "\" & Folder_Name & "\")
If (Len(File) > 0) Then
Call fso.CopyFile(File, Final_Path)
Else
Cells(Row_Number, 2).Interior.ColorIndex = 6
End If
On Error GoTo 0
DoEvents
Next Row_Number
End Sub
I think its unable to use the Branch Code variable as a wildcard, though I might as well have done something silly somewhere in the code. Can someone please help me out?
The problem is you are using the destination path instead of the source path:
File = Dir(DEST_PATH & "*" & Branch_Code & "*.*")
Change it to
File = Dir(SRC_PATH & "*" & Branch_Code & "*.*")
I am opening the excel file in VBA using
Set Workbook = Application.Workbooks.Open(File)
Where
File = "C:\GSTR Automation\GSTR2\February\1000\ReverseCharge\Outputs\ReverseChargeZonic_1000.xlsx"
I am getting the vba error that it could'nt find the file.
But file is present there , I have verified the path manually – karan arora 33 mins ago
I have copied the file location and name from the file still getting the same error – karan arora 30 mins ago
This is not an answer but may help you identify where could be the problem in such a scenario.
Logic:
This code (not fully tested) will take a path and folder by folder will check if it exists. I created the same structure in my C: so that you can see how it works
Code:
Option Explicit
Sub Sample()
Dim sFile As String
Dim Ar As Variant
Dim i As Long
Dim DoesFileExist As Boolean
sFile = "C:\GSTR Automation\GSTR2\February\1000\ReverseCharge\Outputs\ReverseChargeZonic_1000.xlsx"
Ar = Split(sFile, "\")
If UBound(Ar) = 1 Then
MsgBox "File Exists: " & FileFolderExists(sFile)
Else
sFile = Ar(0)
For i = 1 To UBound(Ar)
sFile = sFile & "\" & Ar(i)
DoesFileExist = FileFolderExists(sFile)
If DoesFileExist = False Then
MsgBox sFile & " not found"
Exit Sub
Else
MsgBox sFile & " found"
End If
Next i
End If
End Sub
'~~> Function to check if file/folder exists
Private Function FileFolderExists(strFullPath As String) As Boolean
On Error GoTo Whoa
If Not Dir(strFullPath, vbDirectory) = vbNullString Then FileFolderExists = True
Whoa:
On Error GoTo 0
End Function
In Action:
Now I changed February to January in the above path
Now see how the above code responds
this is my first question so I would love to improve my style and such. Just tell me if I am doing something completely wrong.
My question:
I am searching files with a specific extensions. All results get printed to excel and then create shortcuts to each file which get then stored in a folder. This works perfectly fine for now, but I need the shortcut to include the author detail to filter all entries (hundreds to thousends) for it.
The result should be a shortcut with the same properties that you get when using the 'create shortcut' from context menu vie right click.
I hope you can help my since I am trying to get this to work for a while now.
If you know a solution, that does what I need but is maybe written in a different language that is fine for me as long as the user does not have to install runtimes/libraries (sory I am a complete beginner)
My code:
'This function searches for files with endings (ppt,pptx,pptm) and pastes the found entries into the excel sheet
Function Recurse(sPath As String) As String
Dim FSO As New FileSystemObject
Dim myFolder As Folder
Dim mySubFolder As Folder
Dim myFile As File
Set myFolder = FSO.GetFolder(sPath)
Set Extensions = CreateObject("Scripting.Dictionary")
Extensions.CompareMode = 1 ' make lookups case-insensitive
'Extensions.Add Range("C5").Value, True
Extensions.Add "pptx", True
Extensions.Add "ppt", True
Extensions.Add "pptm", True
For Each mySubFolder In myFolder.SubFolders
For Each myFile In mySubFolder.Files
'
i = Range("D4").Value
If Extensions.Exists(FSO.GetExtensionName(myFile)) Then
Cells(8 + i, 3).Value = myFile.Name
Cells(8 + i, 4).Value = myFile.Path
i = i + 1
Range("D4").Value = i 'storing number of entrys found
'Exit For
End If
Next
Recurse = Recurse(mySubFolder.Path)
Next
End Function
'This Function creates a folder with the name "A1" if it does not exist already
Function PathExist(ByVal vPfadName As String) As Boolean
scutPath = Application.ActiveWorkbook.Path & "\" & Range("A1").Value
On Error GoTo ErrorPathExist
ChDir (vPfadName)
PathExist = True
Exit Function
ErrorPathExist:
MkDir scutPath
End Function
'Main Function that clears table and uses the found entries to get create shortcuts. Unfortunately the author is not integrated when doing it this way. The author is necessary to filter through hundreds of results.
Sub TestR()
Range("B8:C999999") = ""
Range("D4").Value = 0
Call Recurse(Application.ActiveWorkbook.Path)
i = 1
scutPath = Application.ActiveWorkbook.Path & "\" & Range("A1").Value
Call PathExist(scutPath)
For i = 1 To 200 '(last line)
Set oWSH = CreateObject("WScript.Shell")
Set oShortcut = oWSH.CreateShortCut(scutPath & "\" & Cells(7 + i, 3).Value & ".lnk")
With oShortcut
.TargetPath = Cells(7 + i, 4).Value
.Save
End With
Set oWSH = Nothing
Next i
MsgBox "Done"
End Sub
I have this code. It is supposed to check if a file exists and open it if it does. It does work if the file exists, and if it doesn't, however, whenever I leave the textbox blank and click the submit button, it fails. What I want, if the textbox is blank is to display the error message just like if the file didn't exist.
Runtime-error "1004"
Dim File As String
File = TextBox1.Value
Dim DirFile As String
DirFile = "C:\Documents and Settings\Administrator\Desktop\" & File
If Dir(DirFile) = "" Then
MsgBox "File does not exist"
Else
Workbooks.Open Filename:=DirFile
End If
something like this
best to use a workbook variable to provide further control (if needed) of the opened workbook
updated to test that file name was an actual workbook - which also makes the initial check redundant, other than to message the user than the Textbox is blank
Dim strFile As String
Dim WB As Workbook
strFile = Trim(TextBox1.Value)
Dim DirFile As String
If Len(strFile) = 0 Then Exit Sub
DirFile = "C:\Documents and Settings\Administrator\Desktop\" & strFile
If Len(Dir(DirFile)) = 0 Then
MsgBox "File does not exist"
Else
On Error Resume Next
Set WB = Workbooks.Open(DirFile)
On Error GoTo 0
If WB Is Nothing Then MsgBox DirFile & " is invalid", vbCritical
End If
I use this function to check for file existence:
Function IsFile(ByVal fName As String) As Boolean
'Returns TRUE if the provided name points to an existing file.
'Returns FALSE if not existing, or if it's a folder
On Error Resume Next
IsFile = ((GetAttr(fName) And vbDirectory) <> vbDirectory)
End Function
For checking existence one can also use (works for both, files and folders):
Not Dir(DirFile, vbDirectory) = vbNullString
The result is True if a file or a directory exists.
Example:
If Not Dir("C:\Temp\test.xlsx", vbDirectory) = vbNullString Then
MsgBox "exists"
Else
MsgBox "does not exist"
End If
A way that is clean and short:
Public Function IsFile(s)
IsFile = CreateObject("Scripting.FileSystemObject").FileExists(s)
End Function
Function FileExists(ByRef strFileName As String) As Boolean
' TRUE if the argument is an existing file
' works with Unicode file names
On Error Resume Next
Dim objFSO As Object
Set objFSO = CreateObject("Scripting.FileSystemObject")
FileExists = objFSO.FileExists(strFileName)
On Error GoTo 0
End Function
To make the function run faster, objFSO can be made a global variable and the code can be modified and saved in a module like this:
Option Explicit
Dim objFSO As Object
Function FileExists(ByRef strFileName As String) As Boolean
' TRUE if the argument is an existing file
' works with Unicode file names
On Error Resume Next
If objFSO Is Nothing Then Set objFSO = CreateObject("Scripting.FileSystemObject")
FileExists = objFSO.FileExists(strFileName)
On Error GoTo 0
End Function
For strFileName to be a unicode string, you can, for example, either get it from a cell value or define it in a special way, as Excel's VBE doesn't save string constants in Unicode. VBE does support Unicode strings already saved in string variables. You're gonna have to look this up for further details.
Hope this helps somebody ^_^
Maybe it caused by Filename variable
File = TextBox1.Value
It should be
Filename = TextBox1.Value
Speed of Various FileExists Methods
I needed to check file existence for many of my projects, so I wanted to determine the fastest option. I used the micro timer code (see Benchmarking VBA Code) to run the File Exist functions below the table against a local folder with 2865 files to see which was faster. Winner used GetAttr. Using FSO method for Test 2 was a bit faster with the object defined as a global than not, but not as fast as the GetAttr method.
------------------------------------------------------
% of Fastest Seconds Name
------------------------------------------------------
100.00000000000% 0.0237387 Test 1 - GetAttr
7628.42784145720% 1.8108896 Test 2 - FSO (Obj Global)
8360.93687615602% 2.0522254 Test 2 - FSO (Obj in Function)
911.27399562739% 0.2163246 Test 3 - Dir
969.96844814586% 0.2302579 Test 4 - Dir$
969.75108156723% 0.2302063 Test 5 - VBA.Dir
933.82240813524% 0.2216773 Test 6 - VBA.Dir$
7810.66612746275% 1.8541506 Test 7 - Script.FSO
Function FileExistsGA(ByVal FileSpec As String) As Boolean
' Karl Peterson MS VB MVP
Dim Attr As Long
' Guard against bad FileSpec by ignoring errors
' retrieving its attributes.
On Error Resume Next
Attr = GetAttr(FileSpec)
If Err.Number = 0 Then
' No error, so something was found.
' If Directory attribute set, then not a file.
FileExistsGA = Not ((Attr And vbDirectory) = vbDirectory)
End If
End Function
Function FSOFileExists(sFilePathNameExt As String) As Boolean
Dim fso As Object
Set fso = CreateObject("Scripting.FileSystemObject")
FSOFileExists = fso.FileExists(sFilePathNameExt)
Set fso = Nothing
End Function
Function FileExistsDir(sFilePathNameExt As String) As Boolean
If Len(Dir(sFilePathNameExt)) > 0 Then FileExistsDir = True
End Function
Function FileExistsDirDollar(sFilePathNameExt As String) As Boolean
If Len(Dir$(sFilePathNameExt)) > 0 Then FileExistsDirDollar = True
End Function
Function FileExistsVBADirDollar(sFilePathNameExt As String) As Boolean
If Len(VBA.Dir$(sFilePathNameExt)) > 0 Then FileExistsVBADirDollar = True
End Function
Function FileExistsVBADir(sFilePathNameExt As String) As Boolean
If Len(VBA.Dir(sFilePathNameExt)) > 0 Then FileExistsVBADir = True
End Function
Public Function IsFileSFSO(s)
IsFileSFSO = CreateObject("Scripting.FileSystemObject").FileExists(s)
End Function
I realize that this does not fully answer the OP, but is provides information on which of the answers provided seems to be most efficient.
I'll throw this out there and then duck.
The usual reason to check if a file exists is to avoid an error when attempting to open it. How about using the error handler to deal with that:
Function openFileTest(filePathName As String, ByRef wkBook As Workbook, _
errorHandlingMethod As Long) As Boolean
'Returns True if filePathName is successfully opened,
' False otherwise.
Dim errorNum As Long
'***************************************************************************
' Open the file or determine that it doesn't exist.
On Error Resume Next:
Set wkBook = Workbooks.Open(fileName:=filePathName)
If Err.Number <> 0 Then
errorNum = Err.Number
'Error while attempting to open the file. Maybe it doesn't exist?
If Err.Number = 1004 Then
'***************************************************************************
'File doesn't exist.
'Better clear the error and point to the error handler before moving on.
Err.Clear
On Error GoTo OPENFILETEST_FAIL:
'[Clever code here to cope with non-existant file]
'...
'If the problem could not be resolved, invoke the error handler.
Err.Raise errorNum
Else
'No idea what the error is, but it's not due to a non-existant file
'Invoke the error handler.
Err.Clear
On Error GoTo OPENFILETEST_FAIL:
Err.Raise errorNum
End If
End If
'Either the file was successfully opened or the problem was resolved.
openFileTest = True
Exit Function
OPENFILETEST_FAIL:
errorNum = Err.Number
'Presumabley the problem is not a non-existant file, so it's
'some other error. Not sure what this would be, so...
If errorHandlingMethod < 2 Then
'The easy out is to clear the error, reset to the default error handler,
'and raise the error number again.
'This will immediately cause the code to terminate with VBA's standard
'run time error Message box:
errorNum = Err.Number
Err.Clear
On Error GoTo 0
Err.Raise errorNum
Exit Function
ElseIf errorHandlingMethod = 2 Then
'Easier debugging, generate a more informative message box, then terminate:
MsgBox "" _
& "Error while opening workbook." _
& "PathName: " & filePathName & vbCrLf _
& "Error " & errorNum & ": " & Err.Description & vbCrLf _
, vbExclamation _
, "Failure in function OpenFile(), IO Module"
End
Else
'The calling function is ok with a false result. That is the point
'of returning a boolean, after all.
openFileTest = False
Exit Function
End If
End Function 'openFileTest()
Here is my updated code. Checks to see if version exists before saving and saves as the next available version number.
Sub SaveNewVersion()
Dim fileName As String, index As Long, ext As String
arr = Split(ActiveWorkbook.Name, ".")
ext = arr(UBound(arr))
fileName = ActiveWorkbook.FullName
If InStr(ActiveWorkbook.Name, "_v") = 0 Then
fileName = ActiveWorkbook.Path & "\" & Left(ActiveWorkbook.Name, InStr(ActiveWorkbook.Name, ".") - 1) & "_v1." & ext
End If
Do Until Len(Dir(fileName)) = 0
index = CInt(Split(Right(fileName, Len(fileName) - InStr(fileName, "_v") - 1), ".")(0))
index = index + 1
fileName = Left(fileName, InStr(fileName, "_v") - 1) & "_v" & index & "." & ext
'Debug.Print fileName
Loop
ActiveWorkbook.SaveAs (fileName)
End Sub
You should set a condition loop to check the TextBox1 value.
If TextBox1.value = "" then
MsgBox "The file not exist"
Exit sub 'exit the macro
End If
Hope it help you.
I have a spreadsheet that upon clicking a button will duplicate itself by copying/pasting everything to a new workbook and save the file with a name that is dependent upon some variable values (taken from cells on the spreadsheet).
My current goal is to get it to save the sheet in different folders depending on the name of client name (cell value held in variable), while this works on the first run, I get an error after.
The code checks if the directory exists and creates it if not.
This works, but after it is created, running it a second time throws the error:
Runtime Error 75 - path/file access error.
My code:
Sub Pastefile()
Dim client As String
Dim site As String
Dim screeningdate As Date
screeningdate = Range("b7").Value
Dim screeningdate_text As String
screeningdate_text = Format$(screeningdate, "yyyy\-mm\-dd")
client = Range("B3").Value
site = Range("B23").Value
Dim SrceFile
Dim DestFile
If Dir("C:\2013 Recieved Schedules" & "\" & client) = Empty Then
MkDir "C:\2013 Recieved Schedules" & "\" & client
End If
SrceFile = "C:\2013 Recieved Schedules\schedule template.xlsx"
DestFile = "C:\2013 Recieved Schedules\" & client & "\" & client & " " & site & " " & screeningdate_text & ".xlsx"
FileCopy SrceFile, DestFile
Range("A1:I37").Select
Selection.Copy
Workbooks.Open Filename:= _
"C:\2013 Recieved Schedules\" & client & "\" & client & " " & site & " " & screeningdate_text & ".xlsx", UpdateLinks:= _
0
Range("A1:I37").PasteSpecial Paste:=xlPasteValues
Range("C6").Select
Application.CutCopyMode = False
ActiveWorkbook.Save
ActiveWindow.Close
End Sub
You'll have to excuse my lack of knowledge in this area, I am still learning.
I have a very strong feeling it has something to do with the directory checking logic, as when the error is thrown the MkDir line is highlighted.
To check for the existence of a directory using Dir, you need to specify vbDirectory as the second argument, as in something like:
If Dir("C:\2013 Recieved Schedules" & "\" & client, vbDirectory) = "" Then
Note that, with vbDirectory, Dir will return a non-empty string if the specified path already exists as a directory or as a file (provided the file doesn't have any of the read-only, hidden, or system attributes). You could use GetAttr to be certain it's a directory and not a file.
Use the FolderExists method of the Scripting object.
Public Function dirExists(s_directory As String) As Boolean
Dim oFSO As Object
Set oFSO = CreateObject("Scripting.FileSystemObject")
dirExists = oFSO.FolderExists(s_directory)
End Function
To be certain that a folder exists (and not a file) I use this function:
Public Function FolderExists(strFolderPath As String) As Boolean
On Error Resume Next
FolderExists = ((GetAttr(strFolderPath) And vbDirectory) = vbDirectory)
On Error GoTo 0
End Function
It works both, with \ at the end and without.
I ended up using:
Function DirectoryExists(Directory As String) As Boolean
DirectoryExists = False
If Len(Dir(Directory, vbDirectory)) > 0 Then
If (GetAttr(Directory) And vbDirectory) = vbDirectory Then
DirectoryExists = True
End If
End If
End Function
which is a mix of #Brian and #ZygD answers. Where I think #Brian's answer is not enough and don't like the On Error Resume Next used in #ZygD's answer
If Len(Dir(ThisWorkbook.Path & "\YOUR_DIRECTORY", vbDirectory)) = 0 Then
MkDir ThisWorkbook.Path & "\YOUR_DIRECTORY"
End If
This is the cleanest way... BY FAR:
Public Function IsDir(s) As Boolean
IsDir = CreateObject("Scripting.FileSystemObject").FolderExists(s)
End Function
You can replace WB_parentfolder with something like "C:\". For me WB_parentfolder is grabbing the location of the current workbook.
file_des_folder is the new folder i want. This goes through and creates as many folders as you need.
folder1 = Left(file_des_folder, InStr(Len(WB_parentfolder) + 1, file_loc, "\"))
Do While folder1 <> file_des_folder
folder1 = Left(file_des_folder, InStr(Len(folder1) + 1, file_loc, "\"))
If Dir(file_des_folder, vbDirectory) = "" Then 'create folder if there is not one
MkDir folder1
End If
Loop