Check for folder; create if it does not exist

[Riicci]

I had the same problem. I figured I could use Nories old and clean code, then extend it a little bit. Here is my solution:
Sub TestForDir()
Dim strDir As String, tmpDir As String, TestChr As String, DirTest As String
Dim Counter As Integer
strDir = "C:\Users\XXX\Desktop\TestFolder\TestTwo"

For Counter = 1 To Len(strDir)
tmpDir = Left(strDir, Counter - 1)
TestChr = Mid(strDir, Counter, 1)
DirTest = Dir(tmpDir, vbDirectory)

If DirTest = "" And TestChr = "" Then
MkDir tmpDir
MsgBox "Created:" & tmpDir
End If
Next Counter
End Sub

I have similar question, I need to create folder structures and have made this code that does almost everything I need. The problem arise when the code tries to create a folder that has a non valid path to it (meaning that there is a folder before it that is missing).

So far I have seen two problems that might arise when I use this code, the folder already exist or the path is missing a part in it.

I want to the code to move through the entire structure and create all folders, so when there already is a existing folder or a folder link is needed I want a message box to promt the issue and what folder is missing. (preferably I would like a yes/no question if I want to create the missing folder but that is just a bonus).


I have tried using On error goto but cant really get it to work as I am not that familiar with error trapping/handling since before now I have always built macros for personal use and because of that I could always just error handle myself as it happens.

Sub MakeSelectionDir2()

Application.ScreenUpdating = False


On Error GoTo ErrHand


Range("C10").Select



Do Until ActiveCell.Value = "STOP"


dir2 = ActiveCell.Offset(0, 1)




    If Len(Dir(dir2, vbDirectory)) > 0 Then
    
 
       MsgBox "(" & dir2 & ") Folder already exist"
    
       
       Else
       

         MkDir dir2
         
         
         
    End If
    
    
     ActiveCell.Offset(1, 0).Range("A1").Select
         
    
Loop




Application.ScreenUpdating = True


Range("D10").Select


End Sub