在excel按表格列的内容建立目录，麻烦各位大神支招，谢谢

zxc458201

如附件。

为方便每日作业整理，需按“作业跟进表”中“项目”的内容，使用VBA建立一个目录并带超链接。
每次生成目录时，需自动清除上次生成的记录。

麻烦麻烦各位大神支招，谢谢

ykcbf1100

附件供参考。。。

ykcbf1100

文件夹链接

1. Sub ykcbf()   '//2024.12.10
   
2.     Application.ScreenUpdating = False
   
3.     Set fso = CreateObject("Scripting.FileSystemObject")
   
4.     p = ThisWorkbook.Path & ""
   
5.     With Sheets("作业跟进表")
   
6.         r = .Cells(Rows.Count, 1).End(3).Row
   
7.         arr = .[a1].Resize(r, 7)
   
8.         For i = 2 To UBound(arr)
   
9.             If arr(i, 3) <> Empty Then
   
10.                 p1 = p & arr(i, 3)
    
11.                 If Dir(p1, vbDirectory) = "" Then MkDir p1
    
12.                 dd = .Cells(i, 3)
    
13.                 .Hyperlinks.Add Anchor:=.Cells(i, 3), Address:="file://" & p1, TextToDisplay:=dd
    
14.             End If
    
15.         Next
    
16.     End With
    
17.     Application.ScreenUpdating = True
    
18.     MsgBox "OK！"
    
19. End Sub
    
20. 
    

复制代码

longwin

附件供参考。。。。。

longwin

1. Sub test()
   
2. Sheets("目录").[a1].CurrentRegion.Offset(1, 0) = ""
   
3. arr = Sheets("作业跟进表").[a1].CurrentRegion
   
4. Set d = CreateObject("scripting.dictionary")
   
5. For i = 2 To UBound(arr)
   
6.     If arr(i, 3) <> "" Then d(arr(i, 3)) = "作业跟进表!" & Sheets("作业跟进表").Cells(i, 3).Address
   
7. Next
   
8. brr = WorksheetFunction.Transpose(Array(d.keys, d.items))
   
9. With Sheets("目录")
   
10.     For i = 1 To UBound(brr)
    
11.         .Cells(i + 1, 1) = i
    
12.         .Hyperlinks.Add Anchor:=.Cells(i + 1, 3), Address:="", SubAddress:=brr(i, 2), TextToDisplay:=brr(i, 1)
    
13.     Next
    
14. End With
    
15. Set d = Nothing
    
16. End Sub
    

复制代码

zxc458201

谢谢两位大神。
已解决，感谢