遍历文件夹，添加超链接

盘尼西林99

在http://club.excelhome.net/thread-1391369-3-1.html看到ivccav分享的《获取指定文件夹及其子文件夹下所有文件信息、并做成超链接》一文，下载试了一下，很好用。但ivccav分享的用数组提取信息文件中，未加超链接代码。

本人学习VBA时间短，比葫芦画了一个瓢，效果不理想（无法在A列添加超链接，只能在B列添加）。

本人目的：在A列添加超链接。

求大师指导，谢谢！

盘尼西林99

Sub GetAllFiles()
Rem 下载自http://club.excelhome.net/thread-1391369-3-1.html
    Dim pth$, arr
    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行可删除
    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
  
Rem 添加链接  2019－4－17 15时测试，在B列可以添加超链接，并省略后面的代码
        For Each c In .Range("b2:b" & r)
'            .Hyperlinks.Add Anchor:=c, Address:=c.Value, TextToDisplay _
'            :=Split(c, "\")(UBound(Split(c, "\")))
       .Hyperlinks.Add Anchor:=c, Address:=c.Value

rem 请大师修改上面的代码。本人试了一下，如将For Each c In .Range("b2:b" & r)修改为For Each c In .Range("A2:A" & r),貌似加上了超链接，但无法打开文件。
            
        Next
               
        .Range("a1:f" & r).Borders.LineStyle = xlContinuous
        .Range("a1:f" & r).Borders.Weight = xlThin
    End With
    Application.ScreenUpdating = True
    MsgBox "文件已全部获取！点『确定』键结束"
End Sub

Sub Getfd(ByVal pth As String, arr)
    Dim fso As Object, f, fd, ff
    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

wdx223

1. Sub GetAllFiles()
   
2. Rem 下载自http://club.excelhome.net/thread-1391369-3-1.html
   
3.     Dim pth$, arr
   
4.     With Application.FileDialog(msoFileDialogFolderPicker)
   
5.         If .Show = -1 Then
   
6.             pth = .SelectedItems(1)
   
7.         Else
   
8.             MsgBox "您没有选择任何文件夹！", vbCritical: Exit Sub
   
9.         End If
   
10.     End With
    
11.     ReDim arr(1 To 6, 1 To 1)
    
12.     arr(1, 1) = "文件名称"
    
13.     arr(2, 1) = "文件位置"
    
14.     arr(3, 1) = "创建日期"
    
15.     arr(4, 1) = "修改日期"
    
16.     arr(5, 1) = "文件类型"
    
17.     arr(6, 1) = "文件大小"
    
18.     Getfd pth, arr
    
19.     arr = Application.WorksheetFunction.Transpose(arr) '文件信息已保存在arr数组中
    
20.     '实际使用时可不输出到工作表，直接在数组arr中查询需要的文件信息。以下10行可删除
    
21.     For i = 2 To UBound(arr)
    
22.         arr(i, 1) = "=hyperlink(""" & arr(i, 2) & """,""" & arr(i, 1) & """)"
    
23.     Next i
    
24.     Application.ScreenUpdating = False
    
25.     With ActiveSheet
    
26.         .UsedRange.Clear
    
27.         .Cells(1, 1).Resize(UBound(arr, 1), UBound(arr, 2)) = arr
    
28.         r = .Range("a" & Rows.Count).End(3).Row
    
29.         .Range("a1:f" & r).Borders.LineStyle = xlContinuous
    
30.         .Range("a1:f" & r).Borders.Weight = xlThin
    
31.     End With
    
32.     Application.ScreenUpdating = True
    
33.     MsgBox "文件已全部获取！点『确定』键结束"
    
34. End Sub
    
35. 
    
36. Sub Getfd(ByVal pth As String, arr)
    
37.     Dim fso As Object, f, fd, ff
    
38.     Set fso = CreateObject("scripting.filesystemobject")
    
39.     Set ff = fso.getfolder(pth)
    
40.     For Each f In ff.Files
    
41.         ReDim Preserve arr(1 To 6, 1 To UBound(arr, 2) + 1)
    
42.         u = UBound(arr, 2)
    
43.         arr(1, u) = f.Name
    
44.         arr(2, u) = f
    
45.         arr(3, u) = f.DateCreated
    
46.         arr(4, u) = f.DateLastModified
    
47. '        arr(5, u) = f.Type
    
48. Rem 将文件类型修改为文件后缀名     2019-4-15  19:35
    
49.        arr(5, u) = Mid(f.Name, InStrRev(f.Name, ".", -1, 1) + 1)
    
50.        arr(6, u) = Format(f.Size / 1048576, "0.00MB")
    
51.     Next
    
52.     For Each fd In ff.subfolders: Getfd fd, arr: Next
    
53. End Sub

复制代码

盘尼西林99

wdx223 发表于 2019-4-18 17:55

谢谢！刚才测试了一下，很好！

天舞·紫嫣

wdx223 发表于 2019-4-18 17:55

求问，可否同目录刷新超链接，不用每次都一级一级选择。