フォルダの階層構造を書き出してみる ③ ついでにシートに貼り付け

先日、いただいたリクエストに応えて、フォルダの階層構造を書き出してみた。
infoment.hatenablog.com

すると、追加でこんなリクエストをいただいた。
「書き出した各フォルダ名に、ハイパーリンクが設定されていたら最高です」
取り組んでみた。

f:id:Infoment:20200709233257p:plain

まず、ハイパーリンクが設定されている時点で、シートに必ず書き出されている。しかし情報を取得した時点では未だ貼り付け不要で、配列として持っていたい場合もあるだろう。

ということで、新たな引数を一つ準備してみた。

Optional paste_to_new_sheet As Boolean = False

実際に、前回のユーザー定義関数に追加したのがこちら。

Function Tree(folder_path As String, _
     Optional contain_filename As Boolean = False, _
     Optional paste_to_new_sheet As Boolean = False) As Variant
     
    Select Case contain_filename
        Case True
            Tree = Split(CreateObject("wscript.shell").exec("cmd /c tree """ & folder_path & """ /f").stdout.readall, vbCrLf)
        Case False
            Tree = Split(CreateObject("wscript.shell").exec("cmd /c tree """ & folder_path & """").stdout.readall, vbCrLf)
    End Select
    
    Select Case paste_to_new_sheet
        Case False
            Exit Function
        Case True
            Dim Sh As Worksheet
            Set Sh = Sheets.Add
                Sh.Name = "Tree_" & Format(Now, "yyyymmdd_hhmmss")
                Range("A1").Resize(UBound(Tree) + 1) = WorksheetFunction.Transpose(Tree)
                
                With Sh.Cells.Font
                    .Underline = xlUnderlineStyleNone
                    .Name = "メイリオ"
                    .Size = 10
                End With
                
                Sh.Cells.RowHeight = 20
                Sh.Cells.EntireColumn.AutoFit
                Range("A1").Select
    End Select
End Function

結果、取得して貼り付ける側が ↓ ここまで簡素化された。

Sub test()
    Tree "C:\Temp", False, True
End Sub

次いで、ハイパーリンクを設定するためには、フォルダのフルパスが必要だ。そこで安易に、こちらを使って二回目のコマンド使用で解決を試みた。
infoment.hatenablog.com

ところが、得られた結果をツリー図の横に貼り付けてみると、期待通りの並び順になっていない。↓ の例でいえば、「野菜フォルダ」の並びに問題があった。
f:id:Infoment:20200709234640p:plain

ハイパーリンクに設定するためには、取得したフォルダのフルパス群（配列）を昇順ソートする必要が有るようだ。そこで色々と試行錯誤した最終形が、こちら。

Function Tree(folder_path As String, _
     Optional contain_filename As Boolean = False, _
     Optional paste_to_new_sheet As Boolean = False) As Variant
     
    Select Case contain_filename
        Case True
            Tree = Split(CreateObject("wscript.shell").exec("cmd /c tree """ & folder_path & """ /f").stdout.readall, vbCrLf)
        Case False
            Tree = Split(CreateObject("wscript.shell").exec("cmd /c tree """ & folder_path & """").stdout.readall, vbCrLf)
    End Select
    
    Select Case paste_to_new_sheet
        Case False
            Exit Function
        Case True
            Dim Sh As Worksheet
            Set Sh = Sheets.Add
                Sh.Name = "Tree_" & Format(Now, "yyyymmdd_hhmmss")
                Range("A1").Resize(UBound(Tree) + 1) = WorksheetFunction.Transpose(Tree)
           
                If contain_filename = False Then
                
                    Dim arr As Variant
                        arr = Split(CreateObject("wscript.shell").exec("cmd /c Dir """ & folder_path & """ /s /b /ad").stdout.readall, vbCrLf)
        
                    Dim aryList As Object
                    Dim s As Variant
                    Set aryList = CreateObject("System.Collections.ArrayList")
                    
                        For Each s In arr
                            Call aryList.Add(s)
                        Next
                    
                    ' 昇順でソート。
                    Call aryList.Sort
                        arr = aryList.ToArray
                        Rows("1:2").Delete
                    
                        ActiveSheet.Hyperlinks.Add Anchor:=Range("A1"), Address:=Range("A1").Value
                    
                    Dim i As Long
                        For i = 2 To Sh.UsedRange.Rows.Count
                            ActiveSheet.Hyperlinks.Add Anchor:=Cells(i, 1), Address:=arr(i - 1)
                        Next
                
                End If
                
                With Sh.Cells.Font
                    .Underline = xlUnderlineStyleNone
                    .Name = "メイリオ"
                    .Size = 10
                End With
                
                Sh.Cells.RowHeight = 20
                Sh.Cells.EntireColumn.AutoFit
                Range("A1").Select
    End Select
End Function