指定したフォルダ内にサブフォルダを一括作成する

■ExcelのB列3行目以降に記載したフォルダ名で親フォルダ内にサブフォルダを一括作成

①ExcelのB列３行目以降に作成したいサブフォルダのフォルダ名を入力しておく。

②ファイルダイアログでサブフォルダを作成する親フォルダを指定

③指定したフォルダ内にサブフォルダが一括で作成されている。

■コードは以下

Sub CreateDirecotires()
  Dim RootPath As String    '親フォルダパス格納用
  Dim objDialog As Object   'FileDialogオブジェクト格納用
  
  '---------------------------------------------------------------------
  '機能：B列に表記した名前で指定したフォルダ内にサブフォルダを作成する
 '-----------------------------------------------------------------------
  
  'FileDialogオブジェクトをインスタンス化
  Set objDialog = Application.FileDialog(msoFileDialogFolderPicker)
  
  'ダイアログを開いて選択したフォルダを親フォルダパスに指定
  If objDialog.Show Then
    RootPath = objDialog.SelectedItems(1)
  Else
    MsgBox "サブフォルダ作成キャンセル"
  End If
  
 'B列の3行目以降に記載されているフォルダ名で親フォルダ内にサブフォルダを作成
  Dim Row As Long
  Row = 3
  
  Do While Cells(Row, 2).Value <> ""
    Dim CreateDirPath As String
    CreateDirPath = RootPath & "\" & Cells(Row, 2).Value
      
'作ろうとするディレクトリが存在していない場合だけ、フォルダを作成
    If Dir(CreateDirPath, vbDirectory) = "" Then
      MkDir CreateDirPath
    End If
 
    Row = Row + 1
  Loop
End Sub