フォルダ書き出し用VBA for Excel

以前に、フォルダ階層をExcelに書き出すためのVBAをつくったので公開。
変数名がかなり適当なのはやっつけ仕事のためのお約束ということで。

ものはこんな感じ。

フォルダ名をD1に
書出階層数をD2に
フォルダ階層出力はA6から
はじまるようになってます。

とりあえず、以下C:\ドライブを書き出してますがその下の階層でも、
接続ができていればネットワーク上でも、書き出す事はできます。
ネットワーク割付されてれば、そのドライブ名で、
割付されてなければ「\\IPアドレスもしくはNETBIOS名\共有フォルダ名」で指定。
が、現在のログインユーザで
アクセス権がないようなフォルダについてはエラーで止まります。

書出階層数は0を指定すれば、制限ナシで書き出しますが、
指定をすれば、その指定数分の階層までを出力します。

このVBAを使用する場合は、
書き出し用のシートなどの準備は自分でしてください。
あと、とりあえずExcel2000では動いてますが、
他のVerは動作検証してないのであしからず。
バグがあった場合は、勉強だと思って自分で直してください（ぁ

各自で改善してもらう事は問題ありませんが、
このコードそのままの再配布はやめてください。
改善した場合の公開は必ずこちらにリンクをつけてください。
改善した内容などもコメント・トラバに入れてもらうとかなり嬉しいです。
　

ここからVBAコード参照

回帰のカウント用、パブリック変数の指定
以下の本体プログラムの上の行に記述してください。

Public kaikicnt As Integer

本体プログラムはここから。
先にシート上にボタンを用意し、そこからコード入力すること。

Private Sub CommandButton1_Click()
Dim objApl
Dim objFolder
Dim ActFlag

'カウンタ変数（フォルダの階層数）の初期化
kaikicnt = 0
'カーソルをA6に置く
Range("A6").Activate

'アクティブセルに値がはいっている場合
If ActiveCell.Value <> "" Then
'実行するかを確認
ActFlag = MsgBox("データを更新してよろしいですか？", vbYesNo + vbQuestion, "フォルダ書き出し")
If ActFlag = 7 Then
'「いいえ」を押された場合
Exit Sub '処理終了
Else
'「はい」を押された場合
'今のデータを全て消す。
Rows("6:65536").Delete Shift:=xlUp
'カーソルをA6に置く
Range("A6").Activate
End If
End If

'ファイル操作を行うクラスをインスタンス化
Set objFS = CreateObject("Scripting.FileSystemObject")
'D1に入力されたフォルダ名（フルパス）を変数へ
Set objFolder = objFS.GetFolder(Range("D1").Value)

Call prcFolderCHK(objFolder) 'サブルーチン呼び出し

'更新日をセット
Range("D4").Value = Now

MsgBox "書き出し完了。"

End Sub

回帰用サブルーチンはこちら。
上のコードに続けて入力してください。

Sub prcFolderCHK(objFolderA)
Dim motokaiki As Integer
Dim levelcnt As Integer

'カウンタ変数から値を受け取る（元のカウントと比較のため）
motokaiki = kaikicnt
'現在のアクティブセルのアドレスを取得
startadr = ActiveCell.Offset(0, 0).Address

'書き出し階層数を取得
levelcnt = Range("D2").Value

'変数として受け取ったフルパスのサブフォルダ全てをFor文で処理
For Each subf In objFolderA.SubFolders
'あるサブフォルダの名前を取得・・・①
valFolderName = subf.Name
'現在のセルに①で取得したサブフォルダ名をセット
ActiveCell.Value = valFolderName
'一行下のセルをアクティブに
ActiveCell.Offset(1, 0).Activate
'①のサブフォルダ内のサブフォルダ（集合）を取得・・・②
Set colFolders = subf.SubFolders
'②で取得したサブフォルダ数を取得
intFolderCnt = colFolders.Count
'③のサブフォルダ数が０より多い場合（①内にサブフォルダが存在する場合）
If intFolderCnt > 0 Then
'カウンタ変数をインクリメント
kaikicnt = kaikicnt + 1
'一列右のセルをアクティブに
ActiveCell.Offset(0, 1).Activate
'書き出し階層数が0（無限）かカウンタ変数が書き出し階層数-1を越えてない場合のみ
'①のフォルダを元に再呼び出し
If levelcnt - 1 >= kaikicnt Or levelcnt = 0 Then
Call prcFolderCHK(subf)
End If
End If

'このサブルーチンが呼びだされた時よりカウンタ変数が上がっている場合
'（呼び出し時より一列右に移動している場合）
If kaikicnt > motokaiki Then
'一列左に戻す
ActiveCell.Offset(0, -1).Activate
'カウンタ変数をデクリメント
kaikicnt = kaikicnt - 1
End If
Next

End Sub