趣味プログラミングblog

共有PCで、誰かがCドライブを占拠してる場合、
管理者権限でCドライブ全検索かければ、どでかいフォルダの所有者をあぶりだせる。



Dirコマンドの結果からファイル一覧を表示するマクロはネットで見たことがあるけど、
フォルダの一覧を表示するのは見たことがなかった。

で、自分で作ってみたら意外にシンプルにできた。

---

まずは前回同様Dirコマンドの結果について再確認。

以下は、C:\Dirtest に「xxファイル一覧」フォルダを配置して
dir_cmd.vbsで出力したコマンドを実行した際に出力されたファイル。

'-----------------------------------------------------------ここから
ドライブ C のボリューム ラベルがありません。
ボリューム シリアル番号は 4270-BB9E です

C:\Dirtest のディレクトリ ①「のディレクトリ」で終わる

2022/06/24 13:18 18,449,249 CMD_DIR結果の解析.xls ②5文字目、8文字目が「/」
2022/04/08 23:22 10,671,755 Dirリスト.txt ②
2 個のファイル 29,121,004 バイト ③「バイト」で終わり、「個のファイル」を含む

C:\Dirtest\xxファイル一覧 のディレクトリ①

2019/12/07 18:08 1,142 Command Prompt.lnk ②
2022/08/16 13:04 84 desktop.ini ②
2022/09/18 02:26 1,030 dir_cmd.vbs ②
2022/09/22 22:48 0 Dirリスト.txt ②
2022/09/21 00:52 49,873 xx_ファイル・フォルダ一覧_v17.xlsm ②
2022/09/22 22:25 165 ~$xx_ファイル・フォルダ一覧_v17.xlsm ②
2022/08/28 00:05 165 ~$xx_ファイル一覧_v11.xlsm ②
7 個のファイル 52,459 バイト ③

ファイルの総数: ④「 ファイルの総数:」のみの行
9 個のファイル 29,173,463 バイト ④の次の行
0 個のディレクトリ 58,607,783,936 バイトの空き領域 ④の次の次の行
'-----------------------------------------------------------ここまで


出力されるリストのサイズがわからないので、
今回もフルパスをキーとして辞書型配列を使う。

格納したい情報は、サブフォルダを含めてフォルダ内にフォルダやファイルがいくつあって、
ファイルの更新日時の範囲はどの程度で、合計サイズがどのくらいあるか。

ファイルリストのときは、②が出現した時点で格納する情報が確定していたので、
１つの配列に格納できたけど、今回はそうもいかないので、
出力する列ごとにフルパスのフォルダ名をキーとした辞書型変数を用意。

Dim odDic: Set odDic = CreateObject("Scripting.Dictionary") '経路（親）oldDate更新用
Dim ndDic: Set ndDic = CreateObject("Scripting.Dictionary") '経路（親）newDate更新用
Dim mDic: Set mDic = CreateObject("Scripting.Dictionary") '経路（親）ｍフォルダ数更新用
Dim nDic: Set nDic = CreateObject("Scripting.Dictionary") '経路（親）nファイル数更新用
Dim pnDic: Set pnDic = CreateObject("Scripting.Dictionary") '経路（親）nファイル数更新用/s
Dim pxDic: Set pxDic = CreateObject("Scripting.Dictionary") '経路（親）ｘバイト更新用
Dim xDic: Set xDic = CreateObject("Scripting.Dictionary") 'ファイルサイズの合計更新用

---

考え方としては、子フォルダの情報をすべての親フォルダに反映させればOKというもの。
whileループでルートディレクトリに至るまですべてのフォルダをループして情報の更新を行う。

Do While pPath <> rootPath 'rootPath にたどり着くまで親フォルダの情報を更新
pPath = Left(pPath, InStrRev(pPath, "\") - 1) '親フォルダ
'情報の反映処理
Loop

変数の型の関係で、日付の比較はcdateで変換する処理を別関数に飛ばした。

列の入れ替えを想定して、列番号をポインタ式にしたけど、
ほとんど入れ替えず。べた書きのほうがやっぱよかったなぁ。

Dirコマンドの実行結果は、通常ルートディレクトリから順に解析していく。
当初は、最初に出現した①をルートディレクトリとしていたが、
Dirコマンドの条件によってはルートディレクトリ内のファイルがHitせず、
変なフォルダがルートディレクトリとなることがあった。


対策として、Dirリスト.txtの２つ上のフォルダを決め打ちで
ルートディレクトリとして、１つ目のフォルダと不一致の場合はアラートを出すようにした。


めっちゃ苦労してソース書いたけど、
こんなあっさり書き終わるとは拍子抜け・・・。

以下、ソース。ソースファイルは こちら。
最終版のツールセットは こちら。

---

Option Explicit

Sub ■dir結果のファイル解析()
ThisWorkbook.Activate '誤操作防止のために対象ブックを指定

'msgboxに表示するメッセージをrcGetTpath関数に渡して、Dirリスト.txtのパスを取得。
Dim rcMsg As String: rcMsg = "File一覧を出力します。同じディレクトリのDirリスト.txtを指定しますか？"
Dim TargetPath As String: TargetPath = rcGetTpath(rcMsg)

Dim shname As String: shname = Left(Replace(ベースファイル名(TargetPath), "Dirリスト", "Fileリスト"), 31)
Call Select_Make_Sheet(shname) '入力したシートをアクティベート。なければ挿入する。

Dim tictoc As Single
Call ストップウォッチ(tictoc)
Call dir結果のFile解析(TargetPath) 'メインモジュール
Call ストップウォッチ(tictoc)

End Sub

Sub ■dir結果のDir解析()
ThisWorkbook.Activate '誤操作防止のために対象ブックを指定

'msgboxに表示するメッセージをrcGetTpath関数に渡して、Dirリスト.txtのパスを取得。
Dim rcMsg As String: rcMsg = "Dir一覧を出力します。同じディレクトリのDirリスト.txtを指定しますか？"
Dim TargetPath As String: TargetPath = rcGetTpath(rcMsg)

Dim shname As String: shname = Left(ベースファイル名(TargetPath), 31)
Call Select_Make_Sheet(shname) '入力したシートをアクティベート。なければ挿入する。

Dim tictoc As Single
Call ストップウォッチ(tictoc)
Call dir結果のDir解析(TargetPath) 'メインモジュール
Call ストップウォッチ(tictoc)

End Sub

Private Function rcGetTpath(rcMsg As String)
'rcMsgのメッセージを表示して、テキストファイルのフルパスを取得する

Dim RC As Long: RC = MsgBox(rcMsg, vbYesNoCancel)
Dim TargetPath As String

If RC = vbYes Then 'デフォルトファイル
TargetPath = ThisWorkbook.Path & "\" & "Dirリスト.txt"
ElseIf RC = vbNo Then 'ファイルから
TargetPath = txtファイル名取得2(ThisWorkbook.Path)
If TargetPath = "" Then End
Else 'キャンセル
End
End If
rcGetTpath = TargetPath
End Function

Private Function txtファイル名取得2(デフォルト As String)
Dim i As Long
'’https://excel-ubara.com/excelvba1/EXCELVBA376.html
Dim FSO: Set FSO = CreateObject("Scripting.FileSystemObject")
Dim FullName As String
With Application.FileDialog(msoFileDialogFilePicker)
.InitialFileName = デフォルト
.AllowMultiSelect = False
.Filters.Clear
.Filters.Add "テキストファイル", "*.txt"
.Title = "テキストファイルの選択"
If .Show = True Then
FullName = .SelectedItems(1)
Else
MsgBox "キャンセルしました"
End If
End With
Set FSO = Nothing
txtファイル名取得2 = FullName
End Function

Private Sub Select_Make_Sheet(shname As String)
'shnameシートを選択 なければ作って、shnameに応じた列幅をセット
'シートループで該当シートをアクティベートできたかで判断

Dim sh As Long, k As Long
For sh = 1 To Worksheets.Count
If Worksheets(sh).Name = shname Then Worksheets(sh).Activate
Next sh
If ActiveSheet.Name <> shname Then
Worksheets.Add
ActiveSheet.Name = shname
If shname = "Fileリスト" Then
'シートの幅 A B C D E F G H I J
Dim wfArr: wfArr = Split(Replace("4.5 , 52 , 21.88 , 12.13 , 7.13 , 32.63 , 71 , 4.75 , 14.75 , 14.75 ", " ", ""), ",")
For k = 0 To UBound(wfArr)
Cells(1, k + 1).EntireColumn.ColumnWidth = wfArr(k)
Next k
ElseIf shname = "Dirリスト" Then
'シートの幅 A 　B C D E F G H I J K
Dim wdArr: wdArr = Split(Replace("4.5 , 48.25 , 7.25 , 8.13 , 10.75 , 10 , 10.75 , 10.63 , 14.75 , 14.75 , 56.88 ", " ", ""), ",")
For k = 0 To UBound(wdArr)
Cells(1, k + 1).EntireColumn.ColumnWidth = wdArr(k)
Next k
End If
End If
End Sub

Function ベースファイル名(FileName As String) As String 'フルパス対応
Dim pPos As Long: pPos = InStrRev(FileName, ".")
Dim yPos As Long: yPos = InStrRev(FileName, "\")
If yPos > pPos - 1 Then '　拡張子のみファイルは拡張子じゃない
ベースファイル名 = ""
Else
If pPos > 0 Then
ベースファイル名 = Mid(FileName, yPos + 1, pPos - yPos - 1)
Else
ベースファイル名 = ""
End If
End If
End Function


Private Sub dir結果のFile解析(fpath As String)

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
Dim c3buf As String
'タイトル行作成　★区切り文字として「‡」を使用。ファイル名に‡があるとうまく動かない
Const Tgyo = 3
Const strTitle = "File" & "‡" & "Date" & "‡" & "Size" & "‡" & "Ext" & "‡" & "Folder" & "‡" & "FullName" & "‡" & "期"
Dic.Add "FullName", strTitle
Open fpath For Input As #1
Application.StatusBar = "ファイル解析中"
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) = "/" And Path <> "" 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)
If Not Dic.exists(Path & "\" & fname) Then '出るはずない重複が出たので対策
If Dic.Count < Rows.Count - Tgyo Then
Dic.Add Path & "\" & fname, fname & "‡" & strDate & "‡" & fSize & "‡" & Ext & "‡" & ファイル名(Path) & "‡ ‡" & Year(strDate) - 1982 + (Sgn(Month(strDate) - 3.5) - 1) / 2 'Folderそのまま
' Dic.Add Path & "\" & fname, fname & "‡" & strDate & "‡" & fSize & "‡" & Ext & "‡" & AddressToLinkFunc(Path, ファイル名(Path)) & "‡ ‡" & Year(strDate) - 1982 + (Sgn(Month(strDate) - 3.5) - 1) / 2'Folderをリンクへ
End If
Else
Debug.Print Path & "\" & fname
End If
ElseIf buf = " ファイルの総数:" Then '終端まで来たら
Line Input #1, buf 'もう１行読む
c3buf = Trim(buf)
Line Input #1, buf 'もう１行読む
c3buf = Trim(buf) & " " & c3buf
End If
Loop
Close #1
Application.StatusBar = "Arr作成"

'Dicのキーと値を変数に格納して、メモリ解放
Dim keys: keys = Dic.keys
Dim Items: Items = Dic.Items
Set Dic = Nothing

'‡の数を数えて、Arrをリサイズ
Dim cCnt As Long: cCnt = Len(strTitle) - Len(Replace(strTitle, "‡", "")) + 2
Dim Arr(): ReDim Arr(UBound(keys), cCnt) 'Arrはタイトル項目数＋２

'ArrにDicの情報を格納
Dim oBuf, i As Long, j As Long, tmp As String
For i = 0 To UBound(keys)
Arr(i, 0) = i
oBuf = Split(Items(i), "‡")
For j = 0 To UBound(oBuf)
Arr(i, j + 1) = oBuf(j)
Next j
tmp = keys(i)
Arr(i, 6) = tmp '決め打ち
Next i
Arr(0, 0) = "№" '決め打ち

'Arrをエクセルに出力する前にメモリ解放
Set keys = Nothing
Set Items = Nothing

'出力 のまえに初期化
Application.StatusBar = "シートへ出力中"
ActiveSheet.Cells.ClearContents

'出力先の先頭セルを指定して、Arrを貼り付け
Dim OutPutCell As range: Set OutPutCell = Cells(Tgyo, 1)

Const 分割貼り付けフラグ = 0 'メモリ停止対策をするか
If 分割貼り付けフラグ = 0 Then
Call ArrayToCell_2d(OutPutCell, Arr)
Else '1列ずつ貼り付け
Dim k As Long
For k = 0 To UBound(Arr, 2)
Call ArrayToCell_2d(OutPutCell.Offset(0, k), Array2dTo1d(Arr, k))
Next k
End If

Application.StatusBar = "表示調整中"
Call オートフィルタと枠固定と罫線(OutPutCell)

'出力先の書式を設定（日付とサイズ）
Dim OutPutRange As range: Set OutPutRange = OutPutCell.Resize(UBound(Arr, 1) + 1, 1)
OutPutRange.Offset(1, 2).NumberFormatLocal = "yyyy(ge)/mm/dd hh:mm"
OutPutRange.Offset(1, 3).NumberFormatLocal = "#,##0"


Dim txtPath As String: txtPath = ThisWorkbook.Path 'ここのフォルダパス
Dim yPos As Long: yPos = InStrRev(txtPath, "\") '\を右から数えた位置
Dim tarPath As String: tarPath = Left(txtPath, yPos - 1) '対象フォルダパス

Cells(1, "A") = tarPath
Cells(1, "C") = FileDateTime(fpath)
Cells(1, "D") = FileLen(fpath)
Cells(1, "E") = fpath

Cells(2, "C") = c3buf ' buf

' 日付を降順でソート
With ActiveSheet.AutoFilter.range
.Sort Key1:=.range("C2"), Order1:=xlDescending, Header:=xlYes
End With

ReDim Preserve Arr(UBound(Arr, 1), 0) '１列目のみ残して通番を貼り付け
Call ArrayToCell_2d(OutPutCell, Arr)

'期
Dim kiRow As Long
kiRow = OutPutCell.Offset(1, 2).Row '日付１つ目
If Cells(Rows.Count - 1, 1) <> "" Then Cells(1, 2) = "行数上限で破棄"
Application.StatusBar = ""
End Sub

Private Sub オートフィルタと枠固定と罫線(OutPutCell As range)
OutPutCell.Offset(1, 1).Select
ActiveWindow.FreezePanes = True 'ウィンドウ枠の固定ON

OutPutCell.AutoFilter
With ActiveSheet.AutoFilter.range
.CurrentRegion.Borders.LineStyle = xlContinuous
End With
End Sub

Function AddressToLinkFunc(Address As String, Caption As String) As String
AddressToLinkFunc = "=hyperlink(""" & Address & """,""" & Caption & """)"

End Function

Sub ArrayToCell_2d(Target As range, oArr, Optional ColCnt As Long = 0) '2次元配列貼り付け便利モジュール
Dim iRowMax: iRowMax = UBound(oArr, 1) - LBound(oArr, 1) + 1 '// １次元目の要素数を取得 '// 二次元配列の最大行数
Dim iColMax: iColMax = UBound(oArr, 2) - LBound(oArr, 2) + 1 '// ２次元目の要素数を取得'// 二次元配列の最大列数
If iRowMax - 1 > Rows.Count Then iRowMax = Rows.Count - 1
'// Rangeオブジェクトで開始セルから貼り付けるセル範囲を拡張する場合
If ColCnt > 0 And ColCnt <= iColMax Then
' Target.Resize(iRowMax, ColCnt).NumberFormatLocal = "@"
Target.Resize(iRowMax, 1).Offset(0, 5).NumberFormatLocal = "G/標準" 'F列のフォルダは数式
Target.Resize(iRowMax, ColCnt).value = oArr
Else
' Target.Resize(iRowMax, iColMax).NumberFormatLocal = "@"
Target.Resize(iRowMax, 1).Offset(0, 5).NumberFormatLocal = "G/標準" 'F列のフォルダは数式
Target.Resize(iRowMax, iColMax).value = oArr
End If
End Sub

Function getDimention(Arr)
On Error GoTo ANS
Dim i As Long, tmpSize As Long
For i = 1 To 5
tmpSize = UBound(Arr, i)
Next i
ANS:
getDimention = i - 1
End Function

Function Array2dTo1d(Arr, col As Long)
If getDimention(Arr) <> 2 Then Stop '２次元じゃないし
Dim rowMax As Long: rowMax = UBound(Arr)

If rowMax < col Then Stop 'そこにはないし

Dim oArr(): ReDim oArr(rowMax, 0)
Dim i As Long
For i = 0 To rowMax
oArr(i, 0) = Arr(i, col)
Next i
Array2dTo1d = oArr
End Function

Function 拡張子(FileName As String) As String
Dim pPos As Long: pPos = InStrRev(FileName, ".")
Dim yPos As Long: yPos = InStrRev(FileName, "\")
If yPos > pPos - 1 Then '　拡張子のみファイルは拡張子じゃない
拡張子 = ""
Else
If pPos > 0 Then
拡張子 = Right(FileName, Len(FileName) - pPos)
Else
拡張子 = ""
End If
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

Private Sub ストップウォッチ(ByRef tictoc)
If tictoc = 0 Then
tictoc = Timer
Else
Debug.Print "[" & Now & "] "; Format(Timer - tictoc, "0.00秒")
tictoc = Timer
End If
End Sub

Private Sub dir結果のDir解析(Optional fpath As String = "")

Dim buf As String, Path As String, tmpPath
Dim strDate As String, oDate As String, nDate As String, tmpDate As String
Dim c3buf As String
Const Tgyo = 3

Dim odDic: Set odDic = CreateObject("Scripting.Dictionary") '経路（親）oldDate更新用
Dim ndDic: Set ndDic = CreateObject("Scripting.Dictionary") '経路（親）newDate更新用
Dim mDic: Set mDic = CreateObject("Scripting.Dictionary") '経路（親）ｍフォルダ数更新用
Dim nDic: Set nDic = CreateObject("Scripting.Dictionary") '経路（親）nファイル数更新用
Dim pnDic: Set pnDic = CreateObject("Scripting.Dictionary") '経路（親）nファイル数更新用/s
Dim pxDic: Set pxDic = CreateObject("Scripting.Dictionary") '経路（親）ｘバイト更新用
Dim xDic: Set xDic = CreateObject("Scripting.Dictionary") 'ファイルサイズの合計更新用

Dim nxBuf, n As Long, x As Double ', kPos As Long
Dim rootPath As String: rootPath = Left(fpath, InStrRev(fpath, "\") - 1)
rootPath = Left(rootPath, InStrRev(rootPath, "\") - 1)
Dim pPath As String '親フォルダ解析用

Open fpath For Input As #1
Do Until EOF(1)
Line Input #1, buf
If Right(buf, Len("のディレクトリ")) = "のディレクトリ" Then
Path = Trim(Replace(buf, "のディレクトリ", ""))
If Right(Path, 1) = "\" Then Path = Left(Path, Len(Path) - 1)
If tmpDate = "" Then
If rootPath <> Path Then 'tmpDateが入る前は１つ目のディレクトリ
If MsgBox("１つ目の解析対象フォルダとrootPathが一致しません。続行しますか？", vbYesNo) = vbNo Then End
End If
End If
strDate = ""
ElseIf Mid(buf, 5, 1) = "/" And Mid(buf, 8, 1) = "/" And Path <> "" Then 'ファイル解析
tmpDate = Replace(Trim(Mid(buf, 1, 17)), " ", " ")
If strDate = "" Then '１つ目のファイルはまだブランク
oDate = tmpDate
nDate = tmpDate
End If
strDate = tmpDate

oDate = olderDate(oDate, strDate) 'If CDate(strDate) < CDate(oDate) Then oDate = strDate
nDate = newerDate(nDate, strDate) 'If CDate(strDate) > CDate(nDate) Then nDate = strDate

ElseIf Right(buf, 3) = "バイト" And InStr(buf, "個のファイル") > 0 Then 'ディレクトリ内の終端まで来たら

nxBuf = Split(Left(buf, Len(buf) - 3), "個のファイル")
n = Trim(nxBuf(0)) 'n個のファイル
x = Trim(Replace(nxBuf(1), ",", "")) 'xバイト

If pnDic.exists(Path) Then Debug.Print Path & "がDicで重複": Stop '出るはずない重複が出たので念のため

odDic.Add Path, oDate
ndDic.Add Path, nDate
nDic.Add Path, n
pnDic.Add Path, n
pxDic.Add Path, x '総和用
xDic.Add Path, x '単体用

pPath = Path
Do While pPath <> rootPath 'rootPath にたどり着くまで親フォルダの情報を更新
pPath = Left(pPath, InStrRev(pPath, "\") - 1) '親フォルダ
If pnDic.exists(pPath) Then '登場済みの親フォルダ
odDic(pPath) = olderDate(odDic(pPath), oDate) '古いほうの日付を格納
ndDic(pPath) = newerDate(ndDic(pPath), nDate) '新しいほうの日付を格納
mDic(pPath) = mDic(pPath) + 1 'フォルダ数を加算
pnDic(pPath) = pnDic(pPath) + n 'ファイル数を加算
pxDic(pPath) = pxDic(pPath) + x 'サイズを加算
Else '初登場の親フォルダ
odDic.Add pPath, oDate
ndDic.Add pPath, nDate
mDic.Add pPath, 1
pnDic.Add pPath, n
pxDic.Add pPath, x
End If
Loop

ElseIf buf = " ファイルの総数:" Then '終端（3行手前）まで来たら
Line Input #1, buf 'もう１行読む
c3buf = Trim(buf)
Line Input #1, buf 'もう１行読む
c3buf = Trim(buf) & " " & c3buf
End If
Loop
Close #1

Const maxCol = 10
Dim c As Long
Dim iCol: iCol = c: c = c + 1 'i
Dim fCol: fCol = c: c = c + 1 'folder
Dim dCol: dCol = c: c = c + 1 'depth
Dim nCol: nCol = c: c = c + 1 'fileCnt
Dim xCol: xCol = c: c = c + 1 ' size
Dim pnCol: pnCol = c: c = c + 1 'fileCnt/s
Dim pxCol: pxCol = c: c = c + 1 ' size/s
Dim mCol: mCol = c: c = c + 1 'FolderCnt
Dim odCol: odCol = c: c = c + 1 'oldDate
Dim ndCol: ndCol = c: c = c + 1 'newDate
Dim fpCol: fpCol = c: c = c + 1 'targetpath

Dim keys: keys = pnDic.keys
Dim Arr(): ReDim Arr(UBound(keys) + 1, maxCol)
Arr(0, iCol) = "№"
Arr(0, fCol) = "Folder"
Arr(0, dCol) = "depth"
Arr(0, xCol) = "size"
Arr(0, nCol) = "fileCnt"
Arr(0, pxCol) = "size/s"
Arr(0, pnCol) = "fileCnt/s"
Arr(0, mCol) = "FolderCnt"
Arr(0, odCol) = "oldDate"
Arr(0, ndCol) = "newDate"
Arr(0, fpCol) = "FullPath"

Dim oBuf, i As Long, j As Long, tmp, Folder As String, depth As Long
For i = 0 To UBound(keys)
Folder = Mid(keys(i), InStrRev(keys(i), "\") + 1, 99)
tmp = Split(Replace(keys(i), rootPath, "rootPath"), "\")
depth = UBound(tmp)
Arr(i + 1, iCol) = i + 1
Arr(i + 1, fCol) = Folder 'folder
Arr(i + 1, dCol) = depth 'depth
Arr(i + 1, xCol) = xDic(keys(i)) ' size
Arr(i + 1, nCol) = nDic(keys(i)) 'fileCnt/s
Arr(i + 1, pxCol) = pxDic(keys(i)) ' size/s
Arr(i + 1, pnCol) = pnDic(keys(i)) 'fileCnt/s
Arr(i + 1, mCol) = 0 + mDic(keys(i)) 'FolderCnt
Arr(i + 1, odCol) = odDic(keys(i)) 'oldDate
Arr(i + 1, ndCol) = ndDic(keys(i)) 'newDate
Arr(i + 1, fpCol) = keys(i)
Next i

'出力
ActiveSheet.Cells.ClearContents

Dim OutPutCell As range: Set OutPutCell = Cells(Tgyo, 1)
Call ArrayToCell_2d(OutPutCell, Arr)

Call オートフィルタと枠固定と罫線(OutPutCell)

Dim OutPutRange As range: Set OutPutRange = OutPutCell.Resize(UBound(Arr, 1) + 1, 1)
OutPutRange.Offset(1, fCol).NumberFormatLocal = "@"
OutPutRange.Offset(1, dCol).NumberFormatLocal = "#,##0"
OutPutRange.Offset(1, xCol).NumberFormatLocal = "#,##0"
OutPutRange.Offset(1, pxCol).NumberFormatLocal = "#,##0"
OutPutRange.Offset(1, pnCol).NumberFormatLocal = "#,##0"
OutPutRange.Offset(1, mCol).NumberFormatLocal = "#,##0"
OutPutRange.Offset(1, odCol).NumberFormatLocal = "yyyy(ge)/mm/dd"
OutPutRange.Offset(1, ndCol).NumberFormatLocal = "yyyy(ge)/mm/dd"
OutPutRange.Offset(1, fpCol).NumberFormatLocal = "@"

Dim txtPath As String: txtPath = ThisWorkbook.Path 'ここのフォルダパス
Dim yPos As Long: yPos = InStrRev(txtPath, "\")
Dim tarPath As String: tarPath = Left(txtPath, yPos - 1) '対象フォルダパス

Cells(1, "A") = tarPath

Cells(2, "A") = c3buf ' buf

If Cells(Rows.Count - 1, 1) <> "" Then Cells(1, 2) = "行数上限で破棄"

End Sub

Private Function olderDate(strDateA, strDateB) As String
If CDate(strDateA) < CDate(strDateB) Then
olderDate = strDateA
Else
olderDate = strDateB
End If
End Function

Private Function newerDate(strDateA, strDateB) As String
If CDate(strDateA) > CDate(strDateB) Then
newerDate = strDateA
Else
newerDate = strDateB
End If
End Function