忍者ブログ

ド壺

脳内がNotes/Domino系からASP.NETに移行しつつあるIT系情報ブログなつもり。

   

[PR]

×

[PR]上記の広告は3ヶ月以上新規記事投稿のないブログに表示されています。新しい記事を書く事で広告が消えます。

フォルダ書き出し用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
'③のサブフォルダ数が0より多い場合(①内にサブフォルダが存在する場合)
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

拍手[0回]

PR

COMMENT

NAME
TITLE
MAIL(非公開)
URL
EMOJI
Vodafone絵文字 i-mode絵文字 Ezweb絵文字
COMMENT
PASS(コメント編集に必須です)
SECRET
管理人のみ閲覧できます

TRACKBACK

Trackback URL:

カウンター

ブログ内検索

カレンダー

09 2017/10 11
S M T W T F S
1 2 3 4 5 6 7
8 9 10 11 12 13 14
15 16 17 18 19 20 21
22 23 24 25 26 27 28
29 30 31

プロフィール

HN:
nami
性別:
女性
自己紹介:
火星人+/ペガサス/ささ女
の完全変人タイプ。

仕事は1事業所のIT管理者。
ノーツDB開発を主に担当。
鯖管理とNetwork管理にも携わる。
ぶっちゃけIT便利屋。
基本は「広く浅く」。
口癖は「メンドクサ。。。」

ついったーやってます。
@namiphoをフォローしてネ


トラバについて
ここの記事のリンクがない記事については、トラバ許可はしませんのでご承知おきください。

最新コメント

No Title(返信済)
(04/25)
No Title(返信済)
(04/12)
No Title(返信済)
(03/01)
(10/07)
(09/29)

バーコード

アフェリエイト


デル株式会社
シマンテックダウンロードストア

お天気情報

アクセス解析

Copyright ©  -- ド壺 --  All Rights Reserved
Design by CriCri / Photo by Geralt / powered by NINJA TOOLS / 忍者ブログ / [PR]