生成的目录带有超链接功能

ykcbf1100

朱付安 发表于 2024-3-4 16:13
还可以吧，但是a到f列能根据单元格文本大小调整吗，这样有点难看

这个用的就是自适应列宽的。难看指的什么？要靠左排列吗？

朱付安

ykcbf1100 发表于 2024-3-4 16:15
这个用的就是自适应列宽的。难看指的什么？要靠左排列吗？

都靠做吧，老师，那样好看一些

ykcbf1100

朱付安 发表于 2024-3-4 16:19
都靠做吧，老师，那样好看一些

靠左排列。。。

朱付安

ykcbf1100 发表于 2024-3-4 16:24
靠左排列。。。

谢谢老师，这次好看多了

ykcbf1100

新写一个吧，还是喜欢自己写，代码会少一些，用到了Collection。

ykcbf1100

代码供参考。。。

1. Sub ykcbf()   '//2024.3.4
   
2.     Dim fns As New Collection
   
3.     Set sh = ThisWorkbook.Sheets("Sheet1")
   
4.     With Application.FileDialog(msoFileDialogFolderPicker)
   
5.         .Title = "请选择文件夹"
   
6.         .InitialFileName = ThisWorkbook.Path & ""
   
7.         If .Show = -1 Then
   
8.             p = .SelectedItems(1) & ""
   
9.         End If
   
10.     End With
    
11.     Set Fso = CreateObject("Scripting.FileSystemObject")
    
12.     Set ff = Fso.GetFolder(p)
    
13.     GetFiles ff, fns, Fso
    
14.     ReDim brr(1 To fns.Count, 1 To 6)
    
15.     bt = Array("文件名称", "文件位置", "创建日期", "修改日期", "文件类型", "文件大小")
    
16.     For Each f In fns
    
17.         m = m + 1
    
18.         For x = 0 To 5
    
19.             brr(m, x + 1) = f(x)
    
20.         Next
    
21.     Next
    
22.     With sh
    
23.         .Cells.Clear
    
24.         .[a1].Resize(1, 6) = bt
    
25.         .[a1].Resize(1, 6).Interior.Color = 49407
    
26.         With .[a2].Resize(m, 6)
    
27.             .Value = brr
    
28.             .Borders.LineStyle = 1
    
29.             .VerticalAlignment = xlCenter
    
30.             .HorizontalAlignment = xlLeft    '//靠左
    
31.             .Borders.Weight = xlThin
    
32.             .EntireColumn.AutoFit
    
33.         End With
    
34.         For i = 2 To m + 1
    
35.             .Hyperlinks.Add Anchor:=.Cells(i, 1), Address:=.Cells(i, 2)
    
36.         Next
    
37.     End With
    
38. End Sub
    
39. 
    
40. Function GetFiles(ff, fns, Fso)
    
41.     For Each f In ff.Files
    
42.         If f.Name Like "*.xls*" Then
    
43.             If InStr(f, "~$") = 0 Then
    
44.                 If InStr(f, ThisWorkbook.Name) = 0 Then
    
45.                     fns.Add Array(f.Name, f.Path, f.DateCreated, f.DateLastModified, f.Type, Format(f.Size / 1048576, "0.00MB"))
    
46.                 End If
    
47.             End If
    
48.         End If
    
49.     Next
    
50.     For Each fd In ff.SubFolders
    
51.         Call GetFiles(fd, fns, Fso)
    
52.     Next
    
53. End Function
    

复制代码