Results of 1 - 1 of about 44 for VBA ファイル 一覧 階層 (0.013 sec.)
vba (14732), ファイル (15417), 一覧 (5018), 階層 (417)
- [[20180419124335]]
- #score: 10254
- @digest: 271598f287f53aa0cd82ebbcac9a015f
- @id: 76148
- @mdate: 2018-04-20T11:11:47Z
- @size: 8535
- @type: text/plain
- #keywords: emptydirlist (71599), foldersearch (43608), folderlist (41941), tmpfile (41788), dirdata (37491), mysubfolder (30804), tfolder (29993), filenum (27247), pathlist (26885), getline (25864), 空フ (24901), strcmd (10831), readline (10477), targetpath (8417), ブフ (6330), cfiles (5605), fpath (5255), ォル (5178), 階層 (4738), subfolders (4654), ムフ (4547), ルダ (4434), フォ (3633), サブ (3430), myfolder (2785), getfolder (2706), wscript (2129), ト化 (2076), search (1753), fso (1603), ファ (1416), createobject (1410)
- 『空フォルダの削除方法でより効率的な方法ないですか』（すけろく）
自社サーバー内のフォルダ整理をしています。 その過程の中で空フォルダがあれば削除をするのですが、 あまりに数が多く（全体で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 ＞ ---- http://mattintosh.hatenablog.com/entry/20150914/1442235675 FSOが遅いのは割と有名な話です。 Dir関数 または Dirコマンド なとで検索しながら他の方の回答をお待ちください。 サブフォルダを探すのは検索して出来ると思うけど、 空かどうかの判定がちょっとあやふや^^; ちらっと検索限りではズバリのサンプルは無さそうなので、 自分でロジックを考えないといけないけど、 ちょっと思いつかないので、この程度の情報ですみません。 （まっつわん） 2018/04/19(木) 13:19 ---- 横から失礼します。 空フォルダとは? 1.目に見えるファイルやサブフォルダが無い 2.隠しファイルや隠しフォルダも含まれてない 3.目に見えるファイルや隠しファイルが含まれていない(サブフォルダは含まれていても その中に目に見えるファイルや隠しファイルが含まれていない) 4.その他 3.の場合でしたら、FileSystemObjectでフォルダのSizeを取得し0であれば空 フォルダと判定できます。その時点で、そのフォルダ以下は調べなくてもOK、となります。 （カリーニン） 2018/04/19(木) 13:27 ---- まっつわん様 情報ありがとうございます。参考にさせていただきます! 確かにFSOが遅い、というのは良く聞くお話ですね・・。 何か別のアプローチがあれば・・と模索しております。 カリーニン様 返信ありがとうございます。 空フォルダの定義についてですが、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 ---- https://forest.watch.impress.co.jp/library/software/glaryutils/ https://www.gigafree.net/system/clean/emptyfoldelmanager.html 敢えて自作をあきらめる手もありますよ^^; （まっつわん） 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 ---- 余談ながら、DIR命令には並び替えの機能があるのですが、これが Samba による共有等（NAS等、Linuxのファイルサーバはほぼこれ）の場合は無視されてしまうので、並び替えが効かない場合が殆どです。 今回の対象もネットワーク先でしょうから、一覧を得た後に並び替えています。 それと、単純な逆順で済ませており、階層の深い順ではないですが、同じ親なら同じ文字列な訳ですし、これで十分ではないかと思います。 （???） 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... - https://www.excel.studio-kazu.jp/wiki/kazuwiki/201804/20180419124335.txt - [detail] - similar
PREV
NEXT
Powered by Hyper Estraier 1.4.13, with 97049 documents and 608241 words.
訪問者：