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

szbhui

各位大神，本人VBA小白，想实现以下功能：根据单元格内的文件名，查找指定路径里的文件夹，如果有该文件名则自动加上超链接，在论坛里找到了版主：liulang0808 写的一段代码比较适合，但该代码是给固定某一列加入超链接，我是想给某一个区域所有单元格都加上。无奈本人不会修改，请大神帮帮忙，帮我完善一下，附件里有文件。谢谢！



Dim sh As Worksheet
Dim rng As Range
Sub 按钮1_Click()
    Application.ScreenUpdating = False
    For Each sh In Sheets
        With sh
            For j = 2 To .Cells(Rows.Count, 2).End(3).Row
                If Len(.Cells(j, 2)) > 0 Then
                Set rng = .Cells(j, 2)
                Getfd (ThisWorkbook.Path)
                End If
            Next j
        End With
    Next sh
    Application.ScreenUpdating = True
End Sub
Sub Getfd(ByVal pth)
    Set Fso = CreateObject("scripting.filesystemobject")
    Set ff = Fso.getfolder(pth)
    For Each f In ff.Files
        If InStr(f.Name, rng.Value) > 0 Then
            sh.Hyperlinks.Add Anchor:=rng, Address:=f
            Exit Sub
        End If
    Next f
    For Each fd In ff.subfolders
        Getfd (fd)
    Next fd
End Sub




'此代码来源于EXCELHOME论坛版主：liulang0808，感谢版主分享，本人初识VBA，纯小白，肯请各位大神帮忙完善一下，万分感谢！

醉眼看尘世

Dim sh As Worksheet
Dim rng As Range
Sub 按钮1_Click()
    Dim rG As Range
    Application.ScreenUpdating = False
    For Each sh In Sheets
        With sh
            For Each rG In .UsedRange
                If Len(rG.Value) > 0 Then
                    Set rng = rG
                    Getfd (ThisWorkbook.Path)
                End If
            Next
        End With
    Next sh
    Application.ScreenUpdating = True
End Sub
Sub Getfd(ByVal pth)
    Set Fso = CreateObject("scripting.filesystemobject")
    Set ff = Fso.getfolder(pth)
    For Each f In ff.Files
        If InStr(f.Name, rng.Value) > 0 Then
            sh.Hyperlinks.Add Anchor:=rng, Address:=f
            Exit Sub
        End If
    Next f
    For Each fd In ff.subfolders
        Getfd (fd)
    Next fd
End Sub

ykcbf1100

新写一个吧。

ykcbf1100

加超链接

1. Sub ykcbf()    '//2024.7.25  加超链接
   
2.     Cells.Hyperlinks.Delete
   
3.     Application.ScreenUpdating = False
   
4.     Set d = CreateObject("Scripting.Dictionary")
   
5.     Set fso = CreateObject("Scripting.FileSystemObject")
   
6.     p = ThisWorkbook.Path & "\2024年\7月"
   
7.     For Each fd In fso.GetFolder(p).SubFolders
   
8.         For Each f In fd.Files
   
9.             fn = fso.GetBaseName(f)
   
10.             d(fn) = f.Path
    
11.         Next
    
12.     Next
    
13.     r = Cells(Rows.Count, 1).End(3).Row
    
14.     For i = 5 To r
    
15.         For j = 5 To 8
    
16.             s = Cells(i, j)
    
17.             If d.exists(s) Then
    
18.                 ss = d(s)
    
19.                 ActiveSheet.Hyperlinks.Add Anchor:=Cells(i, j), Address:=ss
    
20.             End If
    
21.         Next
    
22.     Next
    
23.     Application.ScreenUpdating = True
    
24. End Sub
    

复制代码

小凡、、、

大概这样吧

szbhui

醉眼看尘世 发表于 2024-7-25 16:21
Dim sh As Worksheet
Dim rng As Range
Sub 按钮1_Click()

非常感谢！实现了大部份的功能，就是现在变成了所有单元格都加上了链接，期望是能定个区域的单元格才需要加链接。比如我只需要E5:H12这个区域内的单元格加链接。

szbhui

ykcbf1100 发表于 2024-7-25 16:36
加超链接

非常感谢，就是我想要的效果，还想请大神帮忙改进一下，就是我想把这个文件放在任何地方都可以操作【加入超链接】那个按钮，还有就是想把路径直接改为文件服务器的共享目录，而且在查找第5行单元格里的文件时，只在B5作为文件夹名字的文件夹内查找，查第6行的时候就只在B6文件夹内查找，帮达到这样的效果吗？再次感谢！

醉眼看尘世

szbhui 发表于 2024-7-25 20:01
非常感谢！实现了大部份的功能，就是现在变成了所有单元格都加上了链接，期望是能定个区域的单元格才需要 ...

.usedrange 改成 .[E5:H12]

szbhui

小凡、、、 发表于 2024-7-25 16:50
大概这样吧

非常感谢，就是我想要的效果，还想请大神帮忙改进一下，就是我想把这个文件放在任何地方都可以操作【加入超链接】那个按钮，还有就是想把路径直接改为文件服务器的共享目录，而且在查找第5行单元格里的文件时，只在B5作为文件夹名字的文件夹内查找，查第6行的时候就只在B6文件夹内查找，帮达到这样的效果吗？再次感谢！

szbhui

醉眼看尘世 发表于 2024-7-25 20:58
.usedrange 改成 .[E5:H12]

谢谢，可以指定区域了