Sub FolderSizeCK()サブフォルダの容量をはかります(*ノ∪`*)

昨日(今朝)20日の記事でふれた、サブフォルダのサイズを調べるマクロです。
メディアにバックアップを取る際、このフォルダとこのフォルダは1枚で焼けるなとか、このフォルダは分割しないと1枚に焼けないなとか、実際に職場でも使っていて結構重宝しています。職場の電算関係の部署が似たようなツールをライブラリに登録していたんですけどバイト単位の表示しかせす、使いづらかったので色んなサイトを参考にして自分で作りました。
お役に立てれば幸いです(*ノ∪`*)


動作確認:OS:Windows7、Windows10/エクセル:2010

Sub FolderSizeCK()
  Dim FolderPath As String
  Dim FSO As Object, f As Variant, cnt As Long
  Set FSO = CreateObject("Scripting.FileSystemObject")
  ChDir ThisWorkbook.Path’Win7ではできたのにWin10ではだめ、なんで?
  Cells.Select
   With Selection
   .Clear
   .ColumnWidth = 8.1
  End With
  Set fd = Application.FileDialog(msoFileDialogFolderPicker)
   With fd
   .Title = "フォルダを選択してください"
    If .Show = True Then
    FolderPath = .SelectedItems(1)
   End If
   End With
   Set fd = Nothing
   'キャンセル時の処理
   If FolderPath = "" Then
   Exit Sub
   End If
   If FolderPath = "ライブラリ" Then ’Win7用?Win10にはない?
   MsgBox "「ライブラリ」は特殊なフォルダなので選択できません"
   Exit Sub
   End If
 For Each f In FSO.GetFolder(FolderPath).SubFolders
  cnt = cnt + 1
  Columns("A:A").Select
  Selection.NumberFormatLocal = "@" '「0911」が「911」等になるのを防ぐ(さっき追加)
  Cells(cnt, 1) = FSO.GetFolder(f).Name
  Cells(cnt, 2) = FSO.GetFolder(f).Size 'バイト
  Cells(cnt, 3) = FSO.GetFolder(f).Size / 1024 'KB
  Cells(cnt, 4) = FSO.GetFolder(f).Size / 1024 / 1024 'MB
  Cells(cnt, 5) = FSO.GetFolder(f).Size / 1024 / 1024 / 1024 'GB
  Cells(cnt, 6) = FSO.GetFolder(f).DateLastModified
  Next f
 Set FSO = Nothing
 Rows("1:1").Select 'ヘッダーを作成
      Selection.Insert Shift:=xlDown, CopyOrigin:=xlFormatFromLeftOrAbove
 Range("A1") = "サブフォルダ名"
 Range("B1") = "バイト"
 Range("C1") = "KB"
 Range("D1") = "MB"
 Range("E1") = "GB"
 Range("F1") = "最終更新日"
  With Selection
   .HorizontalAlignment = xlCenter
   .VerticalAlignment = xlCenter
  End With
 Range("A1").Select
 Selection.CurrentRegion.Select
 With Selection.Borders
 .LineStyle = True
 End With
 Range("C:E").Select
 Selection.NumberFormatLocal = "0.00" '小数点以下2桁固定
 Range("F:F").Select
 Selection.NumberFormatLocal = "gee.mm.dd(aaa)" '和暦で表示、曜日つき
 Columns("A:F").EntireColumn.AutoFit '列幅のオートフィット
 Range("A1:F1").Select
  With Selection.Interior
  .ColorIndex = 37
  End With
  '並び替え(名前順) Win7では並んだのにWin10では並ばなかったので追記
    Range("A1").Select
    Selection.CurrentRegion.Select
    ActiveSheet.Sort.SortFields.Clear
    ActiveSheet.Sort.SortFields.Add Key:=Range("A1"), _
        SortOn:=xlSortOnValues, Order:=xlAscending, DataOption:=xlSortNormal
    With ActiveSheet.Sort
        .SetRange Selection.CurrentRegion
        .Header = xlYes
        .MatchCase = False
        .Orientation = xlTopToBottom
        .SortMethod = xlPinYin
        .Apply
    End With
     Range("A1").Select ’ついでにフィルターもセット
   Selection.CurrentRegion.Select
   Selection.AutoFilter
   Range("E2").Select
 End Sub

職場がWin7で家がWin10なので動作が少し違いました。
並べ替えがしやすいようフィルターも追加しました。
エクスプローラーと比べると小数点以下の端数があいませんが、メディアに焼くときにフォルダの大まかなサイズを調べるために作ったので勘弁してください。結構役に立つツールです。延滞金のユーザー定義関数より需要があるんじゃないかと思います。
スポンサーサイト



訪問者さま
カレンダー
10 | 2016/11 | 12
- - 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 - - -
プロフィール

arakurikaesiki

Author:arakurikaesiki
阿良々木(あらくりかえしき)と申します。趣味はらくがき/アクアリウム、好きな小説は物語シリーズです。あと、仕事で楽したいためにExcelのVBAをちょくちょくいじってます。
なお、当ブログはリンクフリーです、よろしければリンク貼ってください。
また、ブロともさまも募集中です。コメントとかもらえるとすごく喜びます。

ブロとも様募集中ですm(_)m

この人とブロともになる

最新コメント
リンク(敬称略)
らくがき
新着記事
季節の変わり目 Sep 01, 2020
ロード長くね? Aug 19, 2020
ルフィを描いてみた Aug 17, 2020
囲んで塗る? Aug 14, 2020
100.00cm Aug 12, 2020
サメ Aug 08, 2020
チョット多すぎる Aug 08, 2020
・・・・・・ Aug 06, 2020
すず Aug 03, 2020
記憶を辿って Aug 03, 2020
カテゴリ
アクセスランキング
[ジャンルランキング]
ブログ
2006位
アクセスランキングを見る>>

[サブジャンルランキング]
イラストブログ
64位
アクセスランキングを見る>>
にほんブログ村(ビオトープ)
月別アーカイブ
人気ブログランキング
更新通知登録ボタン

更新通知で新しい記事をいち早くお届けします

検索フォーム