ファイル一覧解析マクロ
2020年02月10日
今回は、フォルダ内のファイルの一覧をエクセルシートにするマクロ。
過去にファイル解析マクロをファイルシステムオブジェクトやDIR関数を使って
作ったものの、windowsのコマンドプロンプトで出せることを知った。
きっかけはこのページ。
https://www.excel-chunchun.com/entry/2019/01/03/184325
これに習って、DIR関数で作ってみたものの、
記載のとおり、環境依存文字がパスに含まれるとうまくいかない。
パート２でコマンドプロンプトを紹介していて、
ならそれでいいじゃんと思った次第。
ただ、コマンドプロンプトの結果をファイル出力しても
非常に使いづらいので出力結果ファイルを食って
結果をシートに吐き出すマクロを作った。
まずはコマンドプロンプトを起動。
WIndows+Rでウィンドウを開いて、cmdと入力してエンター。
次にコマンドを入力。
> DIR "フォルダパス" /A-D /S /B > "ファイル名"
これで、指定したフォルダ内のサブフォルダ(/S）を含めて、
フォルダ以外（/A-D)の情報を指定したファイル名（フルパス）に出力。
/B指定で、フルパスだけ出力してくれる。
・
・
/Bありの場合
・
・
最初は/Bありの想定でマクロを作ってみたものの、
フルパスから更新日時やファイルサイズを取得するところでうまくいかず断念。
/Bなしは、必要な情報がすべてそろっているし、
「のディレクトリ」を含む行ならば、左辺を変数に格納するだけなので、意外と簡単に。
それが完成してから/Bありを見直したところ、
ファイルパスの最終文字に制御文字かなにかがはいっていたことが原因と判明。
両方のソースを完成できた。
ちなみに
/Bありは4225ファイルを平均３秒で出力
/Bなしは4224ファイルを平均１秒で出力
/Bなしは不要な情報がファイルにたくさん入っているものの、
/Bありのファイルから情報を取り出す処理のほうが当然重い結果でした。
過去にファイル解析マクロをファイルシステムオブジェクトやDIR関数を使って
作ったものの、windowsのコマンドプロンプトで出せることを知った。
きっかけはこのページ。
https://www.excel-chunchun.com/entry/2019/01/03/184325
これに習って、DIR関数で作ってみたものの、
記載のとおり、環境依存文字がパスに含まれるとうまくいかない。
パート２でコマンドプロンプトを紹介していて、
ならそれでいいじゃんと思った次第。
ただ、コマンドプロンプトの結果をファイル出力しても
非常に使いづらいので出力結果ファイルを食って
結果をシートに吐き出すマクロを作った。
まずはコマンドプロンプトを起動。
WIndows+Rでウィンドウを開いて、cmdと入力してエンター。
次にコマンドを入力。
> DIR "フォルダパス" /A-D /S /B > "ファイル名"
これで、指定したフォルダ内のサブフォルダ(/S）を含めて、
フォルダ以外（/A-D)の情報を指定したファイル名（フルパス）に出力。
/B指定で、フルパスだけ出力してくれる。
/Bなしの場合
ドライブ D のボリューム ラベルがありません。
ボリューム シリアル番号は C423-225F です
D:\Dropbox のディレクトリ
2015/03/11 22:08 10 .dropbox
2016/08/11 01:32 9,681 .picasa.ini
2014/03/29 00:10 6,945 0132777_20140329000950.csv
・・
・
/Bありの場合
D:\Dropbox\.dropbox
D:\Dropbox\.picasa.ini
D:\Dropbox\0132777_20140329000950.csv
・・
・
最初は/Bありの想定でマクロを作ってみたものの、
フルパスから更新日時やファイルサイズを取得するところでうまくいかず断念。
/Bなしは、必要な情報がすべてそろっているし、
「のディレクトリ」を含む行ならば、左辺を変数に格納するだけなので、意外と簡単に。
それが完成してから/Bありを見直したところ、
ファイルパスの最終文字に制御文字かなにかがはいっていたことが原因と判明。
両方のソースを完成できた。
ちなみに
/Bありは4225ファイルを平均３秒で出力
/Bなしは4224ファイルを平均１秒で出力
/Bなしは不要な情報がファイルにたくさん入っているものの、
/Bありのファイルから情報を取り出す処理のほうが当然重い結果でした。
Option Explicit
Sub ◆dir_ADSの解析()
' dir "D:\Dropbox\VBA" /s /a-d > "D:\Dropbox\VBA\dirout.txt"
Dim fPath As String: fPath = txtファイル名取得("DIR /A-D /Sの解析結果ファイルの選択")
If fPath = "" Then Exit Sub
Dim tictoc As Double
tictoc = Timer
'Debug.Print "[" & Now & "] "; Format(Timer - tictoc, "0.00秒")
Dim Dic: Set Dic = CreateObject("Scripting.Dictionary")
Dim buf As String, Path As String
Dim strDate As String, fSize As String, fname As String, Ext As String
'タイトル行作成
Dic.Add "FulName", "Folder" & "‡" & "File" & "‡" & "Date" & "‡" & "Size" & "‡" & "Ext"
Open fPath For Input As #1
Do Until EOF(1)
Line Input #1, buf
If Right(buf, Len("のディレクトリ")) = "のディレクトリ" Then
Path = Trim(Replace(buf, "のディレクトリ", ""))
ElseIf Mid(buf, 5, 1) = "/" And Mid(buf, 8, 1) = "/" Then
strDate = Replace(Trim(Mid(buf, 1, 17)), " ", " ")
fSize = Trim(Mid(buf, 19, 17))
fname = Trim(Mid(buf, 37, Len(buf) - 37 + 1))
Ext = 拡張子(fname)
Dic.Add Path & "\" & fname, AddressToLink(Path, ファイル名(Path)) & "‡" & fname & "‡" & strDate & "‡" & fSize & "‡" & Ext
End If
Loop
Close #1
Dim keys: keys = Dic.keys
Dim Items: Items = Dic.Items
Set Dic = Nothing
Dim Arr(): ReDim Arr(UBound(keys) + 1, 5)
Dim oBuf, i As Long, j As Long
For i = 0 To UBound(keys)
oBuf = Split(Items(i), "‡")
For j = 0 To UBound(oBuf)
Arr(i, j) = oBuf(j)
Next j
Next i
'出力
Worksheets.Add
Dim OutPutCell As Range: Set OutPutCell = Cells(1, 1)
Call ArrayToCell_1d_trns(OutPutCell, keys)
Call ArrayToCell_2d(OutPutCell.Offset(0, 1), Arr)
OutPutCell.Offset(1, 1).Select
ActiveWindow.FreezePanes = True 'ウィンドウ枠の固定ON
OutPutCell.AutoFilter
With ActiveSheet.AutoFilter.Range
.CurrentRegion.Borders.LineStyle = xlContinuous
End With
Dim OutPutRange As Range: Set OutPutRange = OutPutCell.Resize(UBound(keys) + 1, 1)
OutPutRange.Offset(1, 3).NumberFormatLocal = "yyyy/mm/dd hh:mm"
OutPutRange.Offset(1, 4).NumberFormatLocal = "#,##0"
Call ChangeSheetName("dirADS結果")
Cells(1, "H") = AddressToLink(fPath, fPath)
'Dim tictoc As Double
'tictoc = Timer
Debug.Print "[" & Now & "] "; Format(Timer - tictoc, "0.00秒")
End Sub
Sub ◆dirBファイルの解析()
Dim TextBuf As String: TextBuf = TextFileToBuf(txtファイル名取得("DIR /A-D /S /Bの解析結果ファイルの選択"))
If TextBuf = "" Then Exit Sub
Dim tictoc As Double
tictoc = Timer
'Debug.Print "[" & Now & "] "; Format(Timer - tictoc, "0.00秒")
Dim TextArray: TextArray = Split(TextBuf, Chr(10))
Dim TextLine As String, i As Long, cnt As Long: cnt = 1
Dim pPos As Long, yPos As Long, yPos2 As Long
Dim Arr(): ReDim Arr(UBound(TextArray), 5)
Arr(0, 0) = "テキスト"
Arr(0, 1) = "Folder"
Arr(0, 2) = "File"
Arr(0, 3) = "Date"
Arr(0, 4) = "Size"
Arr(0, 5) = "Ext"
On Error Resume Next 'ファイルがなかったりするので
For i = 1 To UBound(TextArray)
TextLine = Left(TextArray(i - 1), Len(TextArray(i - 1)) - 1)
Arr(i, 0) = TextLine ' "テキスト"
If Mid(TextLine, 2, 1) = ":" Then
pPos = InStrRev(TextLine, ".")
yPos = InStrRev(TextLine, "\")
yPos2 = InStrRev(Left(TextLine, yPos - 1), "\")
Arr(i, 1) = AddressToLink(Left(TextLine, yPos - 1), ファイル名(Left(TextLine, yPos - 1))) '"Folder"
Arr(i, 2) = Right(TextLine, Len(TextLine) - yPos) '"File"
Arr(i, 3) = FileDateTime(TextLine) ' "Date"
Arr(i, 4) = FileLen(TextLine) '"Size"
Arr(i, 5) = Right(TextLine, Len(TextLine) - pPos) '"Ext"
End If
Next i
'出力
Worksheets.Add
Call ArrayToCell_2d(Cells(1, 1), Arr)
Call ChangeSheetName("dirB結果")
Dim OutPutCell As Range: Set OutPutCell = Cells(1, 1)
OutPutCell.Offset(0, 3).NumberFormatLocal = "yyyy/mm/dd hh:mm"
OutPutCell.Offset(0, 4).NumberFormatLocal = "#,##0"
Call ArrayToCell_2d(OutPutCell, Arr)
Dim OutPutRange As Range: Set OutPutRange = OutPutCell.Resize(UBound(TextArray) + 1, 1)
OutPutRange.Offset(1, 3).NumberFormatLocal = "yyyy/mm/dd hh:mm"
OutPutRange.Offset(1, 4).NumberFormatLocal = "#,##0"
'Dim tictoc As Double
'tictoc = Timer
Debug.Print "[" & Now & "] "; Format(Timer - tictoc, "0.00秒")
End Sub
Private Sub ChangeSheetName(shName As String)
Dim flag As Boolean
If UsedSheetName(shName) = False Then
ActiveSheet.Name = shName
Exit Sub
End If
Dim cnt As Long: cnt = 2
Dim NewName As String: NewName = shName & " (" & cnt & ")"
Do While UsedSheetName(NewName) = True
cnt = cnt + 1
NewName = shName & " (" & cnt & ")"
Loop
ActiveSheet.Name = NewName
End Sub
Private Function UsedSheetName(shName As String) As Boolean
Dim ws As Worksheet, flag As Boolean
For Each ws In Worksheets
If ws.Name = shName Then flag = True
Next ws
UsedSheetName = flag
End Function
Private Sub ArrayToCell_1d_trns(Target As Range, oArr) '配列貼り付け便利モジュール
Dim iRowMax: iRowMax = UBound(oArr, 1) - LBound(oArr, 1) + 1
Dim iColMax: iColMax = 1 '１列データは転置が必要
Target.Resize(iRowMax, iColMax).Value = WorksheetFunction.Transpose(oArr)
End Sub
Function AddressToLink(Address As String, Caption As String) As String
AddressToLink = "=hyperlink(""" & Address & """,""" & Caption & """)"
End Function
Function Path2Link(Path As String) As String
Path2Link = "=Hyperlink(""" & Path & """,""" & Path & """)"
End Function
Function txtファイル名取得(Optional タイトル As String = "テキストファイルの選択", Optional デフォルト As String = "")
If デフォルト = "" Then
デフォルト = デスクトップパス
End If
Dim i As Long
'’https://excel-ubara.com/excelvba1/EXCELVBA376.html
Dim FSO: Set FSO = CreateObject("Scripting.FileSystemObject")
Dim FulName As String
With Application.FileDialog(msoFileDialogFilePicker)
.InitialFileName = デフォルト
.AllowMultiSelect = False
.Filters.Clear
.Filters.Add "テキストファイル", "*.txt"
.Filters.Add "すべてのファイル", "*.*"
.Title = タイトル
If .Show = True Then
FulName = .SelectedItems(1)
Else
MsgBox "キャンセルしました"
End If
End With
Set FSO = Nothing
txtファイル名取得 = FulName
End Function
Private Function ユーザー名取得()
Dim WshNetworkObject As Object
Set WshNetworkObject = CreateObject("WScript.Network")
ユーザー名取得 = WshNetworkObject.UserName
Set WshNetworkObject = Nothing
End Function
Private Function デスクトップパス()
Dim UserName As String
UserName = ユーザー名取得
デスクトップパス = "C:\Users\" & UserName & "\Desktop"
End Function
Sub ArrayToCell_2d(Target As Range, oArr, Optional ColCnt As Long = 0) '配列貼り付け便利モジュール
Dim iRowMax: iRowMax = UBound(oArr, 1) - LBound(oArr, 1) + 1 '// １次元目の要素数を取得 '// 二次元配列の最大行数
Dim iColMax: iColMax = UBound(oArr, 2) - LBound(oArr, 2) + 1 '// ２次元目の要素数を取得'// 二次元配列の最大列数
'// Rangeオブジェクトで開始セルから貼り付けるセル範囲を拡張する場合
If ColCnt > 0 And ColCnt <= iColMax Then
Target.Resize(iRowMax, ColCnt).Value = oArr
Else
Target.Resize(iRowMax, iColMax).Value = oArr
End If
End Sub
Function 拡張子(FileName As String) As String
Dim pPos As Long
pPos = InStrRev(FileName, ".")
If pPos <> 0 Then
拡張子 = Right(FileName, Len(FileName) - pPos)
Else
拡張子 = ""
End If
End Function
Function ファイル名(FileName As String) As String
Dim yPos As Long
yPos = InStrRev(FileName, "\")
If yPos <> 0 Then
ファイル名 = Right(FileName, Len(FileName) - yPos)
Else
ファイル名 = ""
End If
End Function
Function TextFileToBuf(FullName As String) As String
If FullName = "" Then Exit Function
Dim buf As String
With CreateObject("Scripting.FileSystemObject")
With .GetFile(FullName).OpenAsTextStream
buf = .ReadAll
.Close
End With
End With
TextFileToBuf = buf
End Function
PR
Comment