フォルダを作成する

VBAで標準で用意されているステートメントでは、作成したいフォルダより 上の階層のフォルダが存在しないと作成できません。
つまり、作成したい構成の上位から順番に作っていかないといけないわけです。

で、面倒なので関数を作って見ました。
'///////////////////////////////////////////////////////////
'　ディレクトリの存在チェック
' 返り値： true : 既存
' false : エラーorなし
'///////////////////////////////////////////////////////////
 Function DoesDirExist(path As String) As Boolean
On Error GoTo DoesdirExist_Err
If (GetAttr(path) And vbDirectory) = vbDirectory Then
DoesDirExist = True
Else
DoesDirExist = False
End If
DoesdirExist_End:
Exit Function
DoesdirExist_Err:
DoesDirExist = False
Resume DoesdirExist_End
End Function

'///////////////////////////////////////////////////////////
'　ディレクトリの作成
' 返り値： ＯＫのとき：作成できたフォルダを返す
' ＮＧの時：長さ０の文字列
'///////////////////////////////////////////////////////////
 Function MakeDirectory(path)
On Error GoTo MakeDirectory_Err

'最後に\が無い場合の対処
pos = InStrRev(path, "\")
If Len(path) > pos Then
path = path & "\"
End If

'ドライブが指定されているか調査
pos = InStr(1, path, ":")
If pos > 0 Then
pos = pos + 1
End If
temp_path = Left(path, pos)
'最初の\へ移動
pos = InStr(pos + 1, path, "\")
Do While (pos > 0)
'見つからないディレクトリが見つかり次第作成
temp_path = Left(path, pos)
If DoesDirExist(CStr(temp_path)) = False Then
'見つからないので作成する
MkDir (temp_path)
End If
'次の\の位置を取得
pos = InStr(pos + 1, path, "\")
Loop

MakeDirectory = path

MakeDirectory_End:
Exit Function
MakeDirectory_Err:
MakeDirectory = ""
Resume MakeDirectory_End
End Function