How to optimize this code

[leeqiang]

This code is the code that traverses the file, I want to change this code, so that the result in the second column of the resulting table is added to the hyperlink of the file on the basis of the original, to ensure that clicking on the link can open the file. Thank you!

Option Explicit
   

    Sub GetAllFiles()
    
        Dim pth$, arr, i%, r%
        With Application.FileDialog(msoFileDialogFolderPicker)
            If .Show = -1 Then
                pth = .SelectedItems(1)
            Else
                MsgBox "您没有选择任何文件夹！", vbCritical: Exit Sub
            End If
        End With
        ReDim arr(1 To 6, 1 To 1)
        arr(1, 1) = "文件名称"
        arr(2, 1) = "文件位置"
        arr(3, 1) = "创建日期"
        arr(4, 1) = "修改日期"
        arr(5, 1) = "文件类型"
        arr(6, 1) = "文件大小"
        Getfd pth, arr
        arr = Application.WorksheetFunction.Transpose(arr) '文件信息已保存在arr数组中
        '实际使用时可不输出到工作表，直接在数组arr中查询需要的文件信息。以下10行可删除
        For i = 2 To UBound(arr)
            arr(i, 1) = "=hyperlink(""" & arr(i, 2) & """,""" & arr(i, 1) & """)"
        Next i
        Application.ScreenUpdating = False
        With ActiveSheet
            .UsedRange.Clear
            .Cells(1, 1).Resize(UBound(arr, 1), UBound(arr, 2)) = arr
            r = .Range("a" & Rows.Count).End(3).Row
            .Range("a1:f" & r).Borders.LineStyle = xlContinuous
            .Range("a1:f" & r).Borders.Weight = xlThin
        End With
        Application.ScreenUpdating = True
        [a1].CurrentRegion.AutoFilter Field:=1   '输出结果到工作表，并启用筛选模式
        MsgBox "文件已全部获取！点『确定』键结束"
    End Sub

    Sub Getfd(ByVal pth As String, arr)
        Dim fso As Object, f, fd, ff, u
        Set fso = CreateObject("scripting.filesystemobject")
        Set ff = fso.GetFolder(pth)
        For Each f In ff.Files
            ReDim Preserve arr(1 To 6, 1 To UBound(arr, 2) + 1)
            u = UBound(arr, 2)
            arr(1, u) = f.Name
            arr(2, u) = f
            arr(3, u) = f.DateCreated
            arr(4, u) = f.DateLastModified
    '        arr(5, u) = f.Type
    Rem 将文件类型修改为文件后缀名     2019-4-15  19:35
           arr(5, u) = Mid(f.Name, InStrRev(f.Name, ".", -1, 1) + 1)
           arr(6, u) = Format(f.Size / 1048576, "0.00MB")
        Next
        For Each fd In ff.SubFolders: Getfd fd, arr: Next
       
    End Sub