フォルダ作成マクロ ができるまで その４

はじめに

前回、

vba-belle-equipe.hatenablog.com

ダブルクリックでフォルダ作成マクロが実行できるようになりました。

もういいっちゃいいんですが、実際に使ってみると

あんなこといいな、できたらいいな、となるもんです。

サブフォルダも作りたい

ですよね。

どうせならサブフォルダも含めて一気に作りたいところです。

イメージとしては、

こんな感じで、実行するとサブフォルダまでできるといいな。

考え方

操作は今までどおり

• A1セルをダブルクリックで作成先フォルダの設定
• A1以外のA列をダブルクリックで、フォルダ作成

なので、変えるのは

Sub makeFolders()
  Dim i As Long
  Dim maxRow As Long
  Dim rootPath As String, fldPath As String
  rootPath = Range("A1")
  If Right(rootPath, 1) = "¥" Then
    rootPath = Left(rootPath, Len(rootPath) - 1)
  End If
  If Dir(rootPath, vbDirectory) = "" Then
    MsgBox "作成先フォルダが存在しません"
    Exit Sub
  End If
  maxRow = Cells(Rows.Count, 1).End(xlUp).Row

  '☆☆☆ここから☆☆☆
  For i = 3 To maxRow
    fldPath = rootPath & "¥" & Cells(i, 1)
    If Dir(fldPath, vbDirectory) = "" Then
      MkDir fldPath
    End If
  Next
  '☆☆☆ここまで☆☆☆

End Sub

for文の中でフォルダを次々に作っていく部分です。

パスを渡す

「MkDir」でフォルダが作れることは同じなので、

C:\VBAtest\H27
C:\VBAtest\H27\01
C:\VBAtest\H27\01\a
C:\VBAtest\H27\01\b
       :
       :
       :

こんな感じで文字列を作れればいい。

イメージ

イメージとしては、

こういう感じになってればわかりやすいでしょうか。

フォルダの数（セルが右に続く分）だけ、間に「¥」を入れつつつなげていけばオッケー。

が、実際には灰色の部分がないので、そこを補う必要があります。

6行目であれば、「H27」と「01」を上から持ってきて

C:\VBAtest\H27\01\b

が作れればいいなと。

なおすところ

for文のところを

  For i = 3 To maxRow
    fldPath = rootPath 　'作成先フォルダ
    "[[作成先フォルダに、列数だけ「¥」とフォルダ名をつなげていく]]"
    If Dir(fldPath, vbDirectory) = "" Then
      MkDir fldPath
    End If
  Next
End Sub

とできれば良さそうです。

フォルダ名は、

• セルに値がある場合はそのまま返し、
• 値がない場合はその列を上に見に行って探す

functionを別に作りましょう。

完成形

もろもろを踏まえ、

Sub makeFolders()
  Dim i As Long, j As Long
  Dim maxRow As Long
  Dim maxcol As Long
  Dim rootPath As String, fldPath As String
  rootPath = Range("A1")
  If Right(rootPath, 1) = "¥" Then
    rootPath = Left(rootPath, Len(rootPath) - 1)
  End If
  If Dir(rootPath, vbDirectory) = "" Then
    MsgBox "作成先フォルダが存在しません"
    Exit Sub
  End If
  maxRow = Cells(Rows.Count, 1).End(xlUp).Row
  For i = 3 To maxRow
    maxcol = Cells(i, Columns.Count).End(xlToLeft).Column
    fldPath = rootPath
    For j = 1 To maxcol
      fldPath = fldPath & "¥" & getFolderName(i, j)
    Next
    If Dir(fldPath, vbDirectory) = "" Then
      MkDir fldPath
    End If
  Next
End Sub

Function getFolderName(i As Long, j As Long)
  Dim str As String
  str = Cells(i, j)
  If str <> "" Then
    getFolderName = str
    Exit Function
  End If
  str = Cells(i, j).End(xlUp).Value
  getFolderName = str
End Function

こんな感じでしょうか。

やってみる

ローカル ディスク(C:)
　└VBAtest
　　└H27
    　└01
　　　　└a
　　　　└b
    　└02
　　　　└a
　　　　└b
　　　　└c
　　　　└d
    　└03
    　└04
    　└05
    　└06
    　└07
    　└08
    　└09
    　└10
    　└11
    　└12
　　└H28

オッケーでーす。

まとめ

「こう使いたい」「こうなったらいいのに」という感覚は大事です。

「めんどくさそう」「大変そう」

と、気づかないふりをすることもたまにはあるでしょうが、その感覚にしたがって、頑張ってみるのが、基本的にはいいかなと思います。