VBA Creating a New Folder if Folder Doesn't Already Exist

[Athopp]

Hi All,

First post!

My question is (hopefully) very simple: I need a piece of code to add a new folder if the folder doesn't already exist.

I have a working code that renames folders that appear is column A to their new name in column E (I pulled from the internet). I want to simply add a line of code that creates a new folder for any rows in column E that were not already used to rename a folder. In my example below, I need my code to create a folder for Item # 3 ("3- I am a new folder name).

Column A	Column E
1- Name that is great existing folder v1	1- Name that is great existing folder v2
2- Name that is less great existing folder v1	2- Name that is less great existing folder v2
	3- I am a new folder name

ub MakeFolders()
On Error Resume Next
Dim rowCounter As Integer, colCounter As Integer, totalRows As Integer, totalCols As Integer, charCounter As Integer, ICounter As Integer
Dim FolderPath As String, oldfolderPath As String, newfolderPath As String, folderRenamed As Long
Dim fDialog As FileDialog
Dim invalidChars ' array for invalid characters

invalidChars = Array("?", "<", ">", "/", "\", "|", ":", "*", "_")

Set fDialog = Application.FileDialog(msoFileDialogFolderPicker)

With fDialog
If .Show = True Then
FolderPath = fDialog.SelectedItems(1)
subfolderPath = fDialog.SelectedItems(1)
Else
MsgBox "You didn't select any folder", vbInformation
FolderPath = vbNullString
End If
Worksheets("Rename_Folders").Range("G3") = FolderPath
End With
FolderPath = Sheets("Rename_Folders").Range("G3")

'No action if base folder not selelcted.
If FolderPath = vbNullString Then
MsgBox "Select Meeting Folder to Create Item Folders", vbInformation
Exit Sub
End If

'Get the total folders to rename
totalRows = WorksheetFunction.CountA(Worksheets("Rename_Folders").Range("A:A"))

'No action if folder name contains invalid characters.
For rowCounter = 2 To totalRows
For charCounter = 0 To 7
If InStr(Worksheets("Rename_Folders").Cells(rowCounter, 5), invalidChars(charCounter)) <> 0 Then
MsgBox "Invalid Character " & invalidChars(charCounter) & " found in " _
& Worksheets("Rename_Folders").Cells(rowCounter, 5).Address, vbError
Exit Sub
End If
Next
Next
'rename folders
folderRenamed = 0
For rowCounter = 2 To totalRows
oldfolderPath = FolderPath & "\" & Worksheets("Rename_Folders").Range("A" & rowCounter) 'old name
newfolderPath = FolderPath & "\" & Worksheets("Rename_Folders").Range("E" & rowCounter) 'new name
Exit Sub

'To Check if the old folder name exists or not
If Dir(oldfolderPath, vbDirectory) <> vbNullString Then


'Rename the Folder using Name function
Name oldfolderPath As newfolderPath
folderRenamed = folderRenamed + 1
Else
MsgBox "A New folder for" & vbNewLine & oldfolderPath & vbNewLine & "has been created .", vbInformation
End If
Next
If folderRenamed > 0 Then
MsgBox folderRenamed & " folders created successfully"
End If
Worksheets("Rename_Folders").Range("G3") = ""
FolderPath = vbNullString
End Sub

 

[offthelip]

try this code:

Sub test2()
strDirectory = ActiveWorkbook.Path

Dname1 = strDirectory & "\" & "qwerty"
If (Dir(Dname1, vbDirectory) = "") Then
  MkDir (Dname1)
End If

End Sub

which creates a new folder qwerty in the folder of the activeworkbook

 

[Athopp]

try this code:

Sub test2()
strDirectory = ActiveWorkbook.Path

Dname1 = strDirectory & "\" & "qwerty"
If (Dir(Dname1, vbDirectory) = "") Then
  MkDir (Dname1)
End If

End Sub

which creates a new folder qwerty in the folder of the activeworkbook

Thanks so much for responding!

I've tried to incorporate your suggestion into my existing code (full code with addition in red and excerpt below) but nothing is happening (i.e., the macro is still rename existing folders but not creating new ones for when there is no folder). What am I missing?

If (Dir(newfolderPath, vbDirectory) = "") Then
MkDir (newfolderPath)
End If


Sub MakeFolders()
On Error Resume Next
Dim rowCounter As Integer, colCounter As Integer, totalRows As Integer, totalCols As Integer, charCounter As Integer
Dim FolderPath As String, oldfolderPath As String, newfolderPath As String, folderRenamed As Long
Dim fDialog As FileDialog
Dim invalidChars ' array for invalid characters

invalidChars = Array("?", "<", ">", "/", "\", "|", ":", "*", "_")

Set fDialog = Application.FileDialog(msoFileDialogFolderPicker)

With fDialog
If .Show = True Then
FolderPath = fDialog.SelectedItems(1)
subfolderPath = fDialog.SelectedItems(1)
Else
MsgBox "You didn't select any folder", vbInformation
FolderPath = vbNullString
End If
Worksheets("Rename_Folders").Range("G3") = FolderPath
End With

'No action if base folder not selelcted.
If FolderPath = vbNullString Then
MsgBox "Select Meeting Folder to Create Item Folders", vbInformation
Exit Sub
End If

'Get the total folders to rename
totalRows = WorksheetFunction.CountA(Worksheets("Rename_Folders").Range("A:A"))

'No action if folder name contains invalid characters.
For rowCounter = 2 To totalRows
For charCounter = 0 To 7
If InStr(Worksheets("Rename_Folders").Cells(rowCounter, 5), invalidChars(charCounter)) <> 0 Then
MsgBox "Invalid Character " & invalidChars(charCounter) & " found in " _
& Worksheets("Rename_Folders").Cells(rowCounter, 5).Address, vbError
Exit Sub
End If
Next
Next

'renaming folder
folderRenamed = 0
For rowCounter = 2 To totalRows
oldfolderPath = FolderPath & "\" & Worksheets("Rename_Folders").Range("A" & rowCounter) 'old name
newfolderPath = FolderPath & "\" & Worksheets("Rename_Folders").Range("E" & rowCounter) 'new name

'To Check if the old folder name exists or not
If Dir(oldfolderPath, vbDirectory) <> vbNullString Then

'Rename the Folder using Name function
Name oldfolderPath As newfolderPath
folderRenamed = folderRenamed + 1
Else
MsgBox "Folder named" & vbNewLine & oldfolderPath & vbNewLine & "already exists.", vbInformation
End If
Next
If (Dir(newfolderPath, vbDirectory) = "") Then
MkDir (newfolderPath)
End If
If folderRenamed > 0 Then
MsgBox folderRenamed & " folders created successfully"
End If
Worksheets("Rename_Folders").Range("G3") = ""
FolderPath = vbNullString
End Sub

 

[offthelip]

'You have put the code in the wrong place

'To Check if the old folder name exists or not
If Dir(oldfolderPath, vbDirectory) <> vbNullString Then
If (Dir(newfolderPath, vbDirectory) = "") Then
MkDir (newfolderPath)
End If

'Rename the Folder using Name function
Name oldfolderPath As newfolderPath
folderRenamed = folderRenamed + 1
Else
MsgBox "Folder named" & vbNewLine & oldfolderPath & vbNewLine & "already exists.", vbInformation  ' this statement isn't true!!!!!
End If
Next

 

[Athopp]

This

'You have put the code in the wrong place

'To Check if the old folder name exists or not
If Dir(oldfolderPath, vbDirectory) <> vbNullString Then
If (Dir(newfolderPath, vbDirectory) = "") Then
MkDir (newfolderPath)
End If

'Rename the Folder using Name function
Name oldfolderPath As newfolderPath
folderRenamed = folderRenamed + 1
Else
MsgBox "Folder named" & vbNewLine & oldfolderPath & vbNewLine & "already exists.", vbInformation  ' this statement isn't true!!!!!
End If
Next

Thank you so so much! I can't believe that's what I was missing.