请教关于VBA根据单元格数值为文件名，查找指定路径里的文件夹内，有则自动加超链接

ykcbf1100

szbhui 发表于 2024-7-25 20:42
非常感谢，就是我想要的效果，还想请大神帮忙改进一下，就是我想把这个文件放在任何地方都可以操作【加入 ...

改了，你再试一下。

ykcbf1100

代码更新一下，路径取值有改变。

1. Sub ykcbf()    '//2024.7.26  加超链接
   
2.     Cells.Hyperlinks.Delete
   
3.     Application.ScreenUpdating = False
   
4.     Set fso = CreateObject("Scripting.FileSystemObject")
   
5.     p = ThisWorkbook.Path & ""
   
6.     On Error Resume Next
   
7.     With ThisWorkbook.Sheets("表1")
   
8.         r = .Cells(Rows.Count, 1).End(3).Row
   
9.         Set rng = .[e5].Resize(r - 4, 4)
   
10.         For i = 5 To r
    
11.             rq = .Cells(i, 2)
    
12.             nf = Left(rq, 4) & "年"
    
13.             yf = Val(Mid(rq, 5, 2)) & "月"
    
14.             p1 = p & nf & "" & yf & rq & ""
    
15.             For j = 5 To 8
    
16.                 s = .Cells(i, j)
    
17.                 For Each f In fso.GetFolder(p1).Files
    
18.                     fn = fso.GetBaseName(f)
    
19.                     If fn = s Then
    
20.                         ss = f.Path
    
21.                         ActiveSheet.Hyperlinks.Add Anchor:=.Cells(i, j), Address:=ss
    
22.                     End If
    
23.                 Next
    
24.             Next
    
25.         Next
    
26.         rng.Borders.LineStyle = 1
    
27.     End With
    
28.     Application.ScreenUpdating = True
    
29. End Sub
    

复制代码

szbhui

ykcbf1100 发表于 2024-7-26 11:11
改了，你再试一下。

非常感谢！！！完美预期，太棒了！

szbhui

ykcbf1100 发表于 2024-7-26 11:12
代码更新一下，路径取值有改变。

再请教个问题，清除所有超链接这段代码，能设为只清除超链接，但不清除原本单元格格式吗？谢谢！
Sub del()
  
    Cells.Hyperlinks.Delete '取消当前工作表所有超链接
   
End Sub

ykcbf1100

szbhui 发表于 2024-7-26 11:51
再请教个问题，清除所有超链接这段代码，能设为只清除超链接，但不清除原本单元格格式吗？谢谢！
Sub de ...

单元格格式没有重新设置，只有一句Cells.Hyperlinks.Delete ，保留的代码。