Attribute VB_Name = "dir結果の解析"
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