I'm trying to rename all the sub-folders in a specific folder (C:Users\admin\Documents\AWS). In Column A I have the old folder names, to be changed to the corresponding new names in B.
This is the code I tried (typed in Sheet17 in Visual Basic Editor). Sheet17 is the spreadsheet in the workbook with the two columns of text. All the sub-folders are in the AWS folder.
Sub rename_folder()
Const FILEPATH As String = "C:Users\admin\Documents\AWS\"
Dim strfile As String
Dim filenum As String
strfile = Dir(FILEPATH)
Dim old_name, new_name As String
For i = 2 To Sheets(17).Range("a1").End(xlDown).Row
strOldDirName = FILEPATH & Sheets(17).Cells(i, 1).Value
strNewDirName = FILEPATH & Sheets(17).Cells(i, 2).Value
Name strOldDirName As strNewDirName
Next i
MsgBox "Congratulations! You have successfully renamed all the Folders"
End Sub
I got
Run-time error '53': File not found
when running the code. Couldn't find the Debug Window (I'm on Mac, using Microsoft 2017), but it's probably one of the first few lines of code. Please let me know if any of the subsequent lines should be changed as well.
This worked fine for me.
Sub rename_folder()
Const FILEPATH As String = "C:\Users\Excel\Desktop\test\"
Dim strfile As String
Dim filenum As String
strfile = Dir(FILEPATH)
Dim old_name, new_name As String
For i = 2 To Sheets(1).Range("a2").End(xlDown).Row
strOldDirName = FILEPATH & Sheets(1).Cells(i, 1).Value
strNewDirName = FILEPATH & Sheets(1).Cells(i, 2).Value
Name strOldDirName As strNewDirName
Next i
MsgBox "Congratulations! You have successfully renamed all the Folders"
End Sub
Before:
After:
Could be
Const FILEPATH As String = "C:\Users\admin\Documents\AWS\"
instead of
Const FILEPATH As String = "C:Users\admin\Documents\AWS\"
cause of the missing \ after drive letter
Suppose, we have one folder with only one macro file and every day we are saving excel file in the same folder received via mail. However, filename every day will get changed. I mean to say what ever file we are getting through mail do not have a standard name. Now, we have two files in the same folder.
Can we open another file which we have saved with some random name available in the same folder using a macro? Here, the name of another file is not standard. Additionally, after running a macro, we also want to delete that file.
You can get the filename of the newest file within a directory by this:
Option Explicit
Private Sub GetNewestFilename()
Dim searchDirectory As String
Dim searchPattern As String
Dim currentFilename As String
Dim NewestFilename As String
Dim NewestFiledate As Date
searchDirectory = Application.DefaultFilePath & "\"
searchPattern = "*.xl*"
currentFilename = Dir(searchDirectory & searchPattern, 0)
If currentFilename <> "" Then
NewestFilename = currentFilename
NewestFiledate = FileDateTime(searchDirectory & currentFilename)
Do While currentFilename <> ""
If FileDateTime(searchDirectory & currentFilename) > NewestFiledate Then
NewestFilename = currentFilename
NewestFiledate = FileDateTime(searchDirectory & currentFilename)
End If
currentFilename = Dir
Loop
End If
MsgBox NewestFilename
Dim wb As Workbook
Set wb = Workbooks.Open(searchDirectory & NewestFilename)
' do something
wb.Close SaveChanges:=False
Set wb = Nothing
' Kill searchDirectory & NewestFilename ' Delete the file
End Sub
In my program, i want to browse through a complex file structure, and display the newest file in it.
The file structure has several folders and subfolders, most of the time empty. So this macro would help to reveal where the latest information is.
Sub newestFile()
Dim FileSystem as object
Dim MostRecentFile as string
Dim MostRecentDate as Date
Dim FileSpec as String
Dim filename as string
'This is where i specify what type of files i would be looking for
FileSpec ="*.*"
'This is where i specify where the master directory is, so that i may look down into it
Directory ="c:\Directory1\"
filename = Dir(Directory & FileSpec)
set Filesystem = CreateObject("Scripting.FileSystemObject")
Do Folder FileSystem.getFolder(Directory)
set ws = Sheets("Events")
ws.cells(2,7).value = MostRecentFile
ws.cells(2,8).value = MostRecentDate
end sub
private Function DoFolder(Directory)
For each subfolder in Directory.SubFolders
DoFolder subfolder
Dim file
For each File in Directory.files
'actions go here
If File <> "" Then
MostRecentFile = File
MostRecentDate = FileDateTime(Directory)
If FileDateTime(File) > MostRecentDate Then
MostRecentFile = File
MostRecentDate = FileDateTime(File)
End if
End If
next
next
End Function
on this code i always loose the variables (MostRecentFile and MostRecentDate) when the code goes to another subfolder.
I expected on having the name of the newest file (of the whole structure), and the date.
As was said, scope is certainly a concern. Here's a loop within the subroutine:
Sub newestFile()
Dim FileSystem As Object ' Needed to get file properties
Set FileSystem = CreateObject("Scripting.FileSystemObject")
Dim MostRecentDate As Date
Dim MostRecentFile As String
Directory = "c:\Directory1\"
FileSpec = "*.txt" '<-- can be "*.xls*" or whatever criteria needed
MyFile = ""
'Loop through text files in Directory finding the most current file
MyFile = Dir(Directory & FileSpec) 'Get first file name in directory
Do While MyFile <> ""
If MostRecentDate < FileSystem.GetFile(Directory & MyFile).DateLastModified Then
MostRecentDate = FileSystem.GetFile(Directory & MyFile).DateLastModified
MostRecentFile = MyFile
End If
MyFile = Dir 'Get next file matching criteria
Loop
set ws = Sheets("Events")
ws.cells(2,7).value = MostRecentFile
ws.cells(2,8).value = MostRecentDate
End Sub
You need to declare the variables at module level
Private MostRecentFile as string
Private MostRecentDate as Date
Sub newestFile()
....
End Sub
My code asks the user to input a file name. We'll say we have 5 text files in directory "C:\Users\aUser\Desktop\myFolder". These text files are named A, B, C, D, and E.
If the text file exists, then I would like to write over the contents with a script I've already made. If the text file does not exist, I would like to make one with the file name they inputted, and populate it [with the script I've already written].
Thanks for your help.
The way you explain it, it seems that the easiest workflow would be:
1) Delete the file if exists
Sub test()
Dim FSO As FileSystemObject
Dim sPath As String
sPath = "U:\Test.txt"
Set FSO = New FileSystemObject
If FSO.FileExists(sPath) Then
FSO.DeleteFile (sPath)
End If
End Sub
Copy the script (I assume also a txt file) into the path:
FileCopy "U:\Script", sPath
If you have the script in a string variable:
Set txtFile = FSO.CreateTextFile(sPath, True)
txtFile.WriteLine(sText)
FSO.Close
End Sub
If the script is contained in an array, you can loop through the array and produce multiple writelines.
Don't forget to reference the Microsoft Scripting Runtime library.
Something like this
locates the folder for the logged on user regardless of OS
checks that the user input file is contained in a master list (held by StrFiles)
then either creates a new file if it doesn't exist, or
provides a logic branch for you to add your overrwrite script
Sub
code
GetFiles()
Dim wsShell As Object
Dim objFSO As Object
Dim objFil As Object
Dim strFolder As String
Dim StrFile As String
Dim StrFiles()
StrFiles = Array("A.txt", "B.txt", "C.txt")
Set wsShell = CreateObject("wscript.shell")
strFolder = wsShell.specialFolders("Desktop") & "\myFolder"
StrFile = Application.InputBox("Please enter A.txt, B.txt", "File Selection", , , , , 2)
If IsError(Application.Match(StrFile, StrFiles, 0)) Then
MsgBox StrFile & " is invalid", vbCritical
Exit Sub
End If
If Len(Dir(strFolder & "\" & StrFile)) = 0 Then
'make file
Set objFSO = CreateObject("scripting.filesystemobject")
Set objFil = objFSO.createtextfile(strFolder & "\" & StrFile, 2)
objFil.Close
Else
'write over file
'add your code here
End If
End Sub
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