フォルダ構成を別のフォルダにコピーするマクロ(2) - 素人がExcelVBAによる「一人働き方改革」に挑むブログ

指定したフォルダ内のフォルダ構造をワークシートに書き出す

標準モジュールの宣言セクション

リスト1-1

Option Explicit
Dim fldPicker As FolderPicker

おなじみ、変数宣言の強制と、FolderPickerクラスのインスタンス用の変数宣言。FolderPickerクラスについては、コチラをどうぞ。

セルのクリアとラベルの書き込み

リスト1-2

Sub copyStructureFromOrg()
  Dim objSh As Worksheet
  Set objSh = ActiveSheet    '……(1)'
  With objSh
    .Cells.ClearContents    '……(2)'
    .UsedRange.Borders.LineStyle = xlNone    '……(3)'
    .Range("A2").Value = "フォルダフルパス"    '……(4)'
    .Columns("A").ColumnWidth = 40    '……(5)'
  End With

リスト1-2の説明

(1)で、アクティブシートをオブジェクト変数にセット。
(2)で一旦全てのセルの内容をクリア。
(3)で全ての罫線をクリア。こういうときにはUsedRangeプロパティが便利。
ちなみに、UsedRangeは文字通り使用中のセル、Bordersはセルの境界線のコレクションで、「セルの辺みんな」ぐらいの理解でいいと思う。
(4)でＡ２セルに「フォルダパス」と書き込んでいる。シートの２行目はラベル領域なんだけど、この程度なら毎回書き直しても大した手間ではないので、一旦消してから毎回書き込むようにしている。
(5)で、Ａ列の列幅を「40」にしている。まあ、「40」という数字に深い意味はない。

フォルダ構成コピー元フォルダの指定

FolderPickerクラスを使う。

リスト1-3

  With objSh
    Set fldPicker = New FolderPicker     '……(1)'
    MsgBox "フォルダ構成のコピー元となる親フォルダを指定せよ。"
    With fldPicker
      .showFolderPicker "フォルダ選択( ﾟ∀ﾟ)"     '……(2)'
      If .isCancelled = True Then     '……(3)'
        Exit Sub
      End If
      Dim rootPath As String
      rootPath = fldPicker.gotFolder     '……(4)'
      objSh.Range("C1").Value = "←元の親フォルダ名"
      objSh.Range("B1").Value = .gotFolderName     '……(5)'
    End With
  End With

リスト1-3の説明

(1)で、FolderPickerクラスをインスタンス化。以降、変数fldPickerでFolderPickerオブジェクトを操作することができる。
(2)で、FolderPickerオブジェクトのshowFolderPickerメソッドを実行。引数に「フォルダ選択( ﾟ∀ﾟ)」という文字列を渡しているので、フォルダ選択ダイアログボックスのタイトル部分には「フォルダ選択( ﾟ∀ﾟ)」が表示される。
(3)でフォルダ選択がキャンセルされたかどうか判定。キャンセルされるか、フォルダを選択せずに[ＯＫ]をクリックしていると、FolderPickerオブジェクトのisCancelledプロパティがTrueになっている。Trueだったらこのプロシージャから抜けるようにしている。
(4)では、取得したフォルダパスを変数rootPathにセットしている。showFolderPickerメソッドの実行によりフォルダパスが取得できていたらgotFolderプロパティにフォルダのフルパスがセットされている。
(5)でシートのＢ１セルにフォルダ名を書き込んでいる。gotFolderNameプロパティにはフォルダ名のみの文字列がセットされている。

全てのサブフォルダのフルパスをＡ列に書き込む

前回紹介したwriteAllFolderPathメソッドの出番。

リスト1-4

    Call writeAllFolderPath(rootPath)

リスト1-3の(4)で取得したrootPathを引数として渡してwriteAllFolderPathメソッドを実行。

Ｂ列以降にサブフォルダ名を階層に分けて書き込む

リスト1-5

    Dim lastRow As Integer
    lastRow = .Cells(Rows.Count, 1).End(xlUp).Row     '……(1)'
    Dim i As Integer     '……(2)'
    Dim arryPath As Variant     '……(3)' 
    Dim n As Integer     '……(4)' 
    Dim objStr As String
    With ObjSh
      For i = 3 To lastRow
        objStr = Replace(.Cells(i, 1).Value, rootPath & "\", "", _
                         Compare:=vbTextCompare)    '……(5)'
        arryPath = Split(objStr, "\")   '……(6)'
        For n = 0 To UBound(arryPath)   '……(7)'
          .Cells(i, n + 2).Value = arryPath(n)   '……(8)'
        Next n
      Next i
    End With

リスト1-5の説明

(1)はおなじみの書き込み済み最終行番号の取得。
(2)の「i」はループカウンタ。この後の処理で書き込み対象行番号を指すのに使う。
(3)は、フォルダ名を階層ごとに格納するのに使う配列。
(4)の「n」もループカウンタなんだけど、こっちは書き込み対象列番号を指すのに使う。
(5)は、Replace関数を用いて、フォルダのフルパスからリスト1-3の(4)で取得したrootPathを除いた文字列を変数objStrにセットしている。
指定したフォルダよりも下層にあるフォルダ構成をコピーする、という処理内容なので、指定したフォルダまでのパスは必要ないのでこうしている。
あと、Replace関数の引数CompareにvbTextCompareを指定しているのがポイント。こうしておかないとReplace関数がネットワークドライブのドライブ名の大文字を勝手に小文字に変換してしまうのでうまくいかなかった。
(6)では、Split関数を用いてフォルダ内各階層のフォルダ名を配列として取得。要素数が流動的なので、(3)でVariant型にしていたということ。
だから、(7)でForループの最終値をしていするのもUbound関数を使う。
ここまで準備をしたら、あとは(8)で、列番号（マイナス2）を表すループカウンタ「n」と、行番号を表すループカウンタ「i」を利用して各階層のフォルダ名をセルに書き込んでいく。
階層の深さに応じて右へ右へ書き込んで行き、最下層のフォルダ名まで書き込んだら次の行へ移る、というイメージ。

ラベル書き込みとセルの並べ替え

リスト1-6

    Dim maxCol As Integer
    Dim objCell As Range
    For i = 3 to lastRow    '……(1)'
      'i行目の列数を割り出す'
      n = 1
      Do While .Range("A" & i).Offset(0, n).Value <> ""    '……(2)'
        n = n + 1
      Loop
      If maxCol < n Then    '……(3)'
        maxCol = n
      End If
    Next
    '2行目に列ラベルを書き込む'
    With objSh
      For n = 2 To maxCol    '……(4)'
        .Cells(2, n).Value = "第" & n - 1 & "階層"    '……(5)'
        .Cells(2, n).HorizontalAlignment = xlCenter    '……(6)'
        .Cells(2, n).Borders.LineStyle = xlContinuous    '……(7)'
      Next
    End With

リスト1-6の説明

(1)では、Ａ列の３行目～記入済み最終行までForループを指定。
(2)からの３行は、Ａ列から数えてn番目のセルが空白になるまで「n」をインクリメントする処理。
こうすることで、Doループを抜けたときには変数nがi行目の「データの入っている最終列番号」になる。
たとえば、Ｃ列までデータが入っていたとすると、n = 1でＢ列→ n = 2でＣ列 → n = 3 で空白のＤ列にたどり着いてループから抜けるので、ループから抜けた時点で n は 3、すなわちＣ列を表すということになる。
(3)で n がそれまでのmaxColを上回っていればmaxColを n の値で更新する。
これを i がlastRowになるまで繰り返せば、Forループが終わった段階でmaxColには最も階層が深いフォルダの階層数が入っていることになる。
ここまでの処理で最大行数と最大列数が確定するので、(4)以降のループ処理に移る。
(5)で２行目の各列にラベル名を書き込む。
(6)では２行目各列の文字の配置を中央揃えに。
(7)でlastRow行×maxCol列の範囲に格子状罫線を施している。

最大行数×最大列数のセル領域のうち、空白セルに「0」を書き込む

この後の処理で並べ替える際に、空白セルがあると一番下になってしまう。それを避けるため、一旦空白のセルに全て「0」を書き込むことにする。

リスト1-7

  With objSh
    Dim objRange As Range
    Set objRange = Range(.Cells(3, 1), .Cells(lastRw, maxCol))    '……(1)'
    For Each objCell In objRange    '……(2)'
      If objCell.Value = "" Then
      objCell.Value = "0"
      End If
    Next
  End With

リスト1-7の説明

(1)で変数objRangeに各階層のフォルダ名を書き込んだセル範囲をセット。
(2)では、おなじみのFor Each～Nextを用いて各セルを調べ、空白なら「0」を書き込む。

右端の列から昇順ソートし、一旦「0」にしたセルを空欄に戻す

右端の列から順に昇順ソートすることにより、何列あったとしても並べ替えの優先度を「左端の列→右端の列」にすることができる。

リスト1-8

    For i = maxCol To 2 Step -1   '……(1)'
      objRange.Sort key1:=.Cells(3, i), _
                    order1:=xlAscending
    Next
    For Each objCell In objRange
      If objCell.Value = "0" Then
        objCell.Value = "'0"    '……(2)'
        objCell.Value = ""
      End If
    Next

リスト1-8の説明

(1)だが、先にも書いたとおり並べ替えの優先度の低い方から順に並べ替えをしていくことで、列数にかかわらずうまく並べ替えることができる。
おなじみ、For Each～Nextなんだが、単純に各セルに""を書き込むだけだとなぜかセルの値が「0」扱いになり、(2)のように一旦「'」を付けて文字列にしてから""を書き込むとうまくいった。なぜだかよく分からない。

格子罫線を引いて列幅を調整

リスト1-9

  With objSh
    objRange.Borders.LineStyle = xlContinuous    '……(1)'
    .Range("A2").Borders.LineStyle = xlContinuous    '……(2)'
    .Range(.Columns(2), .Columns(maxCol)).AutoFit    '……(3)'
  End With
  MsgBox "全てのフォルダ構成が書き出されました。"
End Sub