Excelじゆうちょう

Excelのお絵描きツール『りっぷ2(りっぷつぅ)』のサポートページ、まずは「はじめに」をご覧ください。 [NewEntry] [Admin]

記事更新カレンダー

06 « 2018-07 « 08
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 - - - -

やたらに多いカテゴリ

比較的新しい記事

新しいコメント

ありがたいブログ拍手

拍手コメント一覧(拍手はしない)

さみしいトラックバック

申し訳ないプロフィール

申し訳ない

管理人  [ 申し訳ない ]

pxivもやってます
リンクの一番上からのぞきに来てください
※閲覧にはユーザー登録が必要です

RSSってなんぞ?

広告は消せないらしい

FC2Ad

        --------       スポンサーサイト

上記の広告は1ヶ月以上更新のないブログに表示されています。
新しい記事を書く事で広告が消せます。

        2012-09-30       ファイルとフォルダーの一覧作成

どれくらいぶりでしょうか、数えるのが怖いくらい久しぶりにExcel関連の記事を更新します。

テーマは、「ファイルとフォルダーの一覧を作成する」です。

この前、自分の画像ファイルを整理するのに自作してみました。
こんなの探せばわんさか出てきますが、たまにはExcelを触ってあげないとということで作成しました。

今回のポイントとしては、ファイルとフォルダーの一覧をコレクションオブジェクトに格納してから、まとめて出力しているところです。
こうすることで、一覧を取得しながら出力するよりも拡張性が高くなります。
まあ、拡張するつもりはありませんけどね。

詳しい解説は割愛しますが、いっぱいコメントを入れていますので、少しは参考になると思います。
ちなみに、このマクロはThisWorkbookオブジェクトで記述しています。

↓ブックを開くと、自動的に開始されます↓
ファイルとフォルダーの一覧作成、開始

↓フォルダーを黄色く出力↓
ファイルとフォルダーの一覧作成、終了


'コードウインドウ
Private Lng_row As Long '行番号

Private Sub Workbook_NewSheet(ByVal Sh As Object) '新しいシートを追加
main 'ここから開始
End Sub

Private Sub Workbook_Open() 'ブックを開く
main 'ここから開始
End Sub

'ここから開始
Private Sub main()
Dim Path_name As String 'パス名
Dim Flg_folder As Boolean 'ファイルかフォルダーか
With Application.FileDialog(msoFileDialogFolderPicker) 'フォルダーを選択するダイアログ
  If .Show = True Then 'ダイアログを表示、フォルダーを選択すれば
    Path_name = .SelectedItems(1) 'フォルダー名
    Select Case MsgBox(Path_name & Chr(13) & Chr(13) _
      & "このフォルダ配下の一覧を取得します。" & Chr(13) _
      & "フォルダーとファイルの一覧を取得しますか?" & Chr(13) _
      & "(「いいえ」を選択すると、フォルダーのみの一覧を取得します)", vbYesNoCancel)
    Case vbYes 'フォルダーとファイルの一覧
      Flg_folder = True
    Case vbNo 'フォルダーの一覧
      Flg_folder = False
    Case vbCancel 'キャンセルなら
      Exit Sub '帰る
    End Select
    Application.ScreenUpdating = False '画面更新をオフ
    Cells().Clear 'セルをすべてクリア
    Lng_row = 1 '1行目から入力していく
    Cells(Lng_row, 1) = Path_name 'フォルダー名入力
    Cells(Lng_row, 1).Interior.Color = vbYellow '黄色に塗りつぶし
    Lng_row = Lng_row + 1 '次の行
    getFolder Path_name, 2, Flg_folder 'フォルダー配下の一覧を取得
    Application.ScreenUpdating = True '画面更新をオン
  End If
End With
End Sub

'フォルダー配下の一覧を取得
Private Sub getFolder(Fol_path As String, Fol_level As Long, Flg_folder As Boolean)
Dim Clc_file As Collection, Clc_folder As Collection 'コレクションオブジェクト
Dim Var_for As Variant 'コレクションオブジェクトの要素はVariant
Dim File_name As String 'ファイル名
Set Clc_folder = New Collection 'コレクションオブジェクト作成、フォルダー用
Set Clc_file = New Collection 'コレクションオブジェクト作成、ファイル用

File_name = Dir(Fol_path & "\*", vbDirectory) 'フォルダーとファイル一覧
Do While File_name <> "" 'フォルダーかファイルがあれば
  If GetAttr(Fol_path & "\" & File_name) And vbDirectory Then 'フォルダなら
    If File_name <> "." And File_name <> ".." Then 'カレントフォルダーか親フォルダでなければ
      Clc_folder.Add File_name 'フォルダー名を追加
    End If
  Else
    If Flg_folder Then 'フォルダーとファイルの一覧なら
      Clc_file.Add File_name 'ファイル名を追加
    End If
  End If
  File_name = Dir() '次
Loop

For Each Var_for In Clc_file 'ファイル名をすべて繰り返し
  Cells(Lng_row, Fol_level) = Var_for 'ファイル名を入力
  Lng_row = Lng_row + 1 '次の行
Next Var_for
For Each Var_for In Clc_folder 'フォルダー名をすべて繰り返し
  Cells(Lng_row, Fol_level) = Var_for 'フォルダー名を入力
  Cells(Lng_row, Fol_level).Interior.Color = vbYellow '黄色に塗りつぶし
  Lng_row = Lng_row + 1 '次の行
  getFolder Fol_path & "\" & Var_for, Fol_level + 1, Flg_folder 'フォルダー配下の一覧を取得
Next Var_for

Set Clc_folder = Nothing 'コレクションオブジェクト作成、フォルダー用
Set Clc_file = Nothing 'コレクションオブジェクト解放、ファイル用
End Sub


こんなもんでどうかな?
スポンサーサイト

コメント

承認待ちコメント

このコメントは管理者の承認待ちです

承認待ちコメント

このコメントは管理者の承認待ちです

承認待ちコメント

このコメントは管理者の承認待ちです

承認待ちコメント

このコメントは管理者の承認待ちです

承認待ちコメント

このコメントは管理者の承認待ちです

コメントの投稿

管理者にだけ表示を許可  

トラックバック

http://likep.blog63.fc2.com/tb.php/293-777bbf3b

 | HOME | 

上記広告は1ヶ月以上更新のないブログに表示されています。新しい記事を書くことで広告を消せます。