excel如何实现批量超链接

shcw007

版主大大@liulang0808
原文：根据excel单元格内容找到命名包含文件并建立超级链接
http://club.excelhome.net/thread-1396216-1-1.html
(出处: ExcelHome技术论坛)

功能是我想要的功能，但这代码还有其他方式可实现吗？我文件太多，这循环直接就卡死excel，小白求助


Sub 按钮1_Click()
    Application.ScreenUpdating = False
        With ActiveSheet
            For j = 2 To .Cells(Rows.Count, 8).End(3).Row
                If Len(.Cells(j, 8)) > 0 Then
                Set rng = .Cells(j, 8)
                Getfd ("\\171.20.241.1\技术\报价\2019")
                End If
            Next j
        End With
    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
            ActiveSheet.Hyperlinks.Add Anchor:=rng, Address:=f
            Exit Sub
        End If
    Next f
    For Each fd In ff.subfolders
        Getfd (fd)
    Next fd
End Sub

liulang0808

Dim arr(), brr, a
Sub 按钮1_Click()
    Application.ScreenUpdating = False
    Set fso = CreateObject("scripting.filesystemobject")
    a = 0
    Call Getfd(ThisWorkbook.Path, fso)
        With ActiveSheet
            brr = .Cells(1, 2).Resize(.Cells(Rows.Count, 2).End(3).Row)
            For j = 2 To UBound(brr)
                If Len(brr(j, 1)) > 0 Then
                    For i = 1 To UBound(arr, 2)
                        If InStr(arr(2, i), brr(j, 1)) > 0 Then
                            ActiveSheet.Hyperlinks.Add Anchor:=.Cells(j, 2), Address:=arr(1, i)
                        End If
                    Next i
                End If
            Next j
        End With
    Application.ScreenUpdating = True
End Sub
Sub Getfd(ByVal pth, fso)
    Set ff = fso.getfolder(pth)
    For Each f In ff.Files
        a = a + 1
        ReDim Preserve arr(1 To 2, 1 To a)
        arr(1, a) = f
        arr(2, a) = f.Name
    Next f
    For Each fd In ff.subfolders
        Call Getfd(fd, fso)
    Next fd
End Sub

liulang0808

用之前的案例做了调整，具体文件夹位置了，楼主根据需求调整吧，预计能提速一些

zpy2

("\\171.20.241.1\
这个是内网的文件夹，速度慢，是不是网络的原因，如果换成本地文件夹是不是会快一点？

shcw007

liulang0808 发表于 2020-1-13 12:12
用之前的案例做了调整，具体文件夹位置了，楼主根据需求调整吧，预计能提速一些

非常感谢，历遍还是会卡死（假死），但比之前快多了，至少等了后有结果了。
另外请教大大，如何调整可以将文件所在位置做超链接，打开不是文件本身而是所在文件夹呢
再次谢谢大大的帮助

shcw007

zpy2 发表于 2020-1-13 14:27
("\\171.20.241.1\
这个是内网的文件夹，速度慢，是不是网络的原因，如果换成本地文件夹是不是会快一点？

版主调整后还是很快的

liulang0808

shcw007 发表于 2020-1-13 14:56
非常感谢，历遍还是会卡死（假死），但比之前快多了，至少等了后有结果了。
另外请教大大，如何调 ...

Sub Getfd(ByVal pth, fso)
    Set ff = fso.getfolder(pth)
    For Each f In ff.Files
        a = a + 1
        ReDim Preserve arr(1 To 2, 1 To a)
        arr(1, a) = ff
        arr(2, a) = f.Name
    Next f
    For Each fd In ff.subfolders
        Call Getfd(fd, fso)
    Next fd
End Sub
这样修改看看是否可行吧

shcw007

liulang0808 发表于 2020-1-13 20:43
Sub Getfd(ByVal pth, fso)
    Set ff = fso.getfolder(pth)
    For Each f In ff.Files

谢谢大大，可行