[ 初めての方へ | 一覧(最新更新順) | 全文検索 | 過去ログ ]
『空フォルダの削除方法でより効率的な方法ないですか』（すけろく）
自社サーバー内のフォルダ整理をしています。
その過程の中で空フォルダがあれば削除をするのですが、
あまりに数が多く（全体で1億フォルダほど）、手作業では
無理と判断し、VBAでコードを組みました。
消すこと自体はなんとかできているのですが、For-NextやDo-Loopで
ぐるぐるまわしていることもあり、かなりの時間を要しています。
より効率的な（作業時間を短縮できるような）方法がありましたら
ご教示いただけますと助かります。
現在のおおまかなロジックは
1.基本となるフォルダを指定
2.再帰処理でフォルダ内にサブフォルダやファイルの無いフォルダを
リスト化
3.2のリストを削除
4.2と3をリスト化できなくなるまで繰り返す
です。
現状組んでいるコードは下記になります。
Dim Cnt As Long Dim FSO As Object Dim FolderList()
Sub TEST()
Dim i as Long
Set FSO = CreateObject("Scripting.FileSystemObject")
Do
Call FolderSearch("C:\TEST(1)")
If UBound(FolderList) = -1 Then Exit Do
For i = 0 To UBound(FolderList)
FSO.DeleteFolder FolderList(i)
Next i
FolderList = Array()
Cnt = 0
Loop
Set FSO = Nothing
End Sub
Sub FolderSearch(myFolder)
Dim mySubFolder
With FSO.GetFolder(myFolder)
If .SubFolders.Count > 0 Then
For Each mySubFolder In .SubFolders
If FSO.GetFolder(mySubFolder).SubFolders.Count = 0 And FSO.GetFolder(mySubFolder).Files.Count = 0 Then
ReDim Preserve FolderList(Cnt)
FolderList(Cnt) = mySubFolder
Cnt = Cnt + 1
End If
Call FolderSearch(mySubFolder)
Next
End If
End With
End Sub
＜ 使用 Excel：Excel2010、使用 OS：Windows7 ＞
FSOが遅いのは割と有名な話です。
Dir関数 または Dirコマンド
なとで検索しながら他の方の回答をお待ちください。
サブフォルダを探すのは検索して出来ると思うけど、
空かどうかの判定がちょっとあやふや＾＾；
ちらっと検索限りではズバリのサンプルは無さそうなので、
自分でロジックを考えないといけないけど、
ちょっと思いつかないので、この程度の情報ですみません。
（まっつわん） 2018/04/19(木) 13:19
空フォルダとは？
1.目に見えるファイルやサブフォルダが無い
2.隠しファイルや隠しフォルダも含まれてない
3.目に見えるファイルや隠しファイルが含まれていない(サブフォルダは含まれていても
その中に目に見えるファイルや隠しファイルが含まれていない)
4.その他
3.の場合でしたら、FileSystemObjectでフォルダのSizeを取得し0であれば空
フォルダと判定できます。その時点で、そのフォルダ以下は調べなくてもOK、となります。
（カリーニン） 2018/04/19(木) 13:27
カリーニン様
返信ありがとうございます。
空フォルダの定義についてですが、3となります。
なるほど。上位階層のフォルダサイズが0だと確かに削除対象ですね。
しかしながら、ファイル数が多かったり、階層が深かったりすれば時間が
かかってしまいます。
ただ単にフォルダサイズが0か否かというような判定ってできるんでしょうか。
（すけろく） 2018/04/19(木) 14:13
まず、フォルダ一覧は、私がここで良く書いている DIR /B/S を利用したものを探し、パラメータを /B/S/A:D として、親フォルダ下の*.*を指定してみてください。 全部シートに吐くと量が多い場合、少し下の階層を指定して試すと良いでしょう。
後は、FSOでも使って、ファイル数フォルダ数サイズ等の情報を得て判定し、削除していけば良いでしょう。 ファイル含めてフォルダを消す、コマンドプロンプトの RMDIR /S/Q という手もあります。
問題は、サムネイルやExcelの排他情報等のシステムファイル属性を消せるかですね。普通に消そうとしても、システムファイル関係だからということで、OSに拒否されてしまうはずです。
（???） 2018/04/19(木) 16:53
敢えて自作をあきらめる手もありますよ＾＾；
（まっつわん） 2018/04/19(木) 16:59
???様
いろいろ検索もしながら下記コードを作成し、フォルダ一覧も取得できました。
あとは取得できた順で判定しながら削除となります。
例えば「C:\TEST(1)\TEST1\Test2」というようなフォルダ構成があり、
基本となるフォルダ(TEST(1))以下がすべて空フォルダの場合には
C:\TEST(1)のみが残るようにするため、
C:\TEST(1)\TEST1\Test2
C:\TEST(1)\TEST1
の順で削除しなければいけないと思うのですが（これはsizeを取得したときに
データが多いフォルダだと時間がかかるため）、階層の深さ順に並べ替える
必要がありますよね？
Sub TEST2()
Dim Fl
Fl = FolderSearch("C:\TEST(1)", "*.*")
For i = 0 To UBound(Fl)
Debug.Print Fl(i)
Next i
End Sub
Function FolderSearch(SEARCH_DIR, SEARCH_FILE)
Dim TMPFile As String
Dim strCmd As String
Dim buf() As Byte
Dim FileNum As Long
Dim TargetPath
TMPFile = Environ("TEMP") & "\Dir.tmp"
strCmd = "Dir """ & SEARCH_DIR & "\" & SEARCH_FILE & """ /b/s/a:d > """ & TMPFile & """"
With CreateObject("Wscript.Shell")
.Run "cmd /c" & strCmd, 7, True
End With
If Len(Dir(TMPFile)) Then
If FileLen(TMPFile) < 1 Then
Kill TMPFile
TargetPath = Array("")
Exit Function
End If
Else
TargetPath = Array("")
Exit Function
End If
FileNum = FreeFile
Open TMPFile For Binary As #FileNum
ReDim buf(1 To LOF(FileNum))
Get #FileNum, , buf
Close #FileNum
Kill TMPFile
FolderSearch = Split(StrConv(buf, vbUnicode), vbCrLf)
End Function
まっつわん様
自社のルールでフリーソフトはNGでした。
手間を考えると有償のソフトウェアの購入を上長に懇願しましたが
結果NGでした。(^^;)
（すけろく） 2018/04/20(金) 09:43
Sub test()
Const cPATH = "C:\TEST(1)\"
Dim AR As Object
Dim cFiles() As String
Dim i As Long
Set AR = CreateObject("System.Collections.ArrayList")
cFiles = Split(CreateObject("WScript.Shell").Exec("CMD /C DIR /A:D/B/S """ & cPATH & "*.*""").StdOut().ReadAll(), vbNewLine)
For i = 0 To UBound(cFiles) - 1
AR.Add cFiles(i)
Next i
AR.Sort
AR.Reverse
For i = 0 To AR.Count - 1
Cells(i + 1, "A").Value = AR(i)
Next i
End Sub
問題は、これに該当するフォルダ数が幾つあるかですねぇ。 数の問題でコントロールが対応できずエラー停止してしまうようならば、何回かに分けて、サブフォルダを親に指定するしかないでしょう。
（???） 2018/04/20(金) 17:46
それと、単純な逆順で済ませており、階層の深い順ではないですが、同じ親なら同じ文字列な訳ですし、これで十分ではないかと思います。
（???） 2018/04/20(金) 18:01
なんとなく書いてみた とりあえずは動いた
Const tFolder = "D:\"
CMDLine = "CMD /C DIR /A /S " & tFolder & " | FIND /V ""/"""
Set emptyDirList = CreateObject("Scripting.Dictionary")
Set DirData = CreateObject("WScript.Shell").Exec(CMDLine).StdOut
Do Until DirData.AtEndOfStream
getLine = DirData.ReadLine
If InStr(getLine, " のディレクトリ") Then
getPath = Mid(getLine, 2, InStrRev(getLine, " ") - 2)
DirData.ReadLine
emptyDirList.Add getPath, CLng(Left(DirData.ReadLine, 16))
End If
Loop
If Right(tFolder, 2) = ":\" Then emptyDirList.Remove tFolder
pathList = emptyDirList.Keys
For n = UBound(pathList) To LBound(pathList) Step -1
fPath = pathList(n)
If emptyDirList.Exists(fPath) Then
If emptyDirList.Item(fPath) Then
Do While emptyDirList.Exists(fPath)
emptyDirList.Remove fPath
fPath = Left(fPath, InStrRev(fPath, "\") - 1)
Loop
End If
End If
Next
Debug.Print Join(emptyDirList.Keys, vbCrLf)
問題点としてはFAT32だとemptyDirList.Keysのソートが必要になるかも？ （2u） 2018/04/20(金) 20:11
[ 一覧(最新更新順) ]
YukiWiki 1.6.7 Copyright (C) 2000,2001 by Hiroshi Yuki.
Modified by kazu.