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 & "*.*")
The problem has been narrowed down to one line. It is an issue between absolute and relative path.
This line works:
PlayWavFile "c:\TransmissionFile\AWNP.wav", False
I prefer something like this but it does not work:
PlayWavFile "AWNP.wav", False
I have the wave file in both the C drive and in the same folder as the program. So for the program folder to be portable, I would like to use the relative path. How do I do that? What is wrong?
Try this:
Dim CurrentFolder As String
CurrentFolder = ThisWorkbook.Path
PlayWavFile CurrentFolder & Application.PathSeparator & "AWNP.wav", False
Your question leaves a few open questions. However, taking a best guess approach, I think this is what you're aiming to do:
Option Explicit
' assuming this is the Lib declaration:
Public Declare Function sndPlaySound Lib "winmm.dll" _
Alias "sndPlaySoundA" (ByVal lpszSoundName As String, _
ByVal uFlags As Long) As Long
' and assuming this is the sub format you're using to call (as declared) sndPlaySound
Sub PlayWavFile(WavFileName As String, Wait As Boolean)
' Set path based on this workbook's folder location
Dim stFilePath$: stFilePath = ThisWorkbook.Path & "\" & WavFileName
' If file is missing, try root of C drive
If Dir(stFilePath) = "" Then
stFilePath = "C:\" & WavFileName
' Not here either: report and end
If Dir(stFilePath) = "" Then
MsgBox WavFileName & " not found"
Exit Sub
End If
End If
' Play the sound (with/without wait)
If Wait Then
sndPlaySound stFilePath, 0
Else
sndPlaySound stFilePath, 1
End If
End Sub
Im trying to create a folder in a network location which is already created and then name the new folder a value of 2 cell references combined on a specific sheet.
Dim strFilename, strDirname, strPathname, strDefpath As String
'On Error Resume Next
strDirname = ContractorChecklistSheet.Range("B6" & "B7").Value
strFilename = ContractorChecklistSheet.Range("B6" & "B7").Value
strDefpath = "T:\Projects\"
MkDir strDefpath & strDirname
strPathname = strDefpath & strDirname & "" & strFilename
If IsEmpty(filename) Then Exit Sub
End Sub
but i cant get it to work, the code halts on strDirname, can someone please help.
If you have a worksheet with a CodeName of ContractorChecklistSheet then this updated Range will work
strDirname = ContractorChecklistSheet.Range("B6").Value & ContractorChecklistSheet.Range("B7").Value
Else if your Excel tab is named ContractorChecklistSheet, then try
strDirname = Sheets("ContractorChecklistSheet").Range("B6").Value & Sheets("ContractorChecklistSheet").Value
Note that you should use error checking on MkDir to ensure the folder name is valid
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
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