ExcelHome技术论坛

 找回密码
 免费注册

QQ登录

只需一步,快速开始

EH搜索     
EH技术汇-专业的职场技能充电站 妙哉!函数段子手趣味讲函数 Excel服务器-会Excel,做管理系统 Excel Home精品图文教程库
Excel不给力? 何不试试FoxTable! Excel 2016函数公式学习大典 Office知识技巧免费学 打造核心竞争力的职场宝典
300集Office 2010微视频教程 Tableau-数据可视化工具 精品推荐-800套精选PPT模板,点击获取 ExcelHome出品 - VBA代码宝免费下载
你的Excel 2010实战技巧学习锦囊 欲罢不能, 过目难忘的 Office 新界面 Excel VBA经典代码实践指南
查看: 310|回复: 7

[求助] excel如何实现批量超链接

[复制链接]

TA的精华主题

TA的得分主题

发表于 2020-1-13 11:47 | 显示全部楼层 |阅读模式
版主大大@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


TA的精华主题

TA的得分主题

发表于 2020-1-13 12:11 | 显示全部楼层
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

评分

参与人数 2鲜花 +5 收起 理由
达州张先生 + 3 值得肯定
shcw007 + 2 感谢帮助

查看全部评分

TA的精华主题

TA的得分主题

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

示例及其说明.zip

33.68 KB, 下载次数: 14

评分

参与人数 2鲜花 +5 收起 理由
达州张先生 + 3 值得肯定
zpy2 + 2 优秀作品

查看全部评分

TA的精华主题

TA的得分主题

发表于 2020-1-13 14:27 来自手机 | 显示全部楼层
("\\171.20.241.1\
这个是内网的文件夹,速度慢,是不是网络的原因,如果换成本地文件夹是不是会快一点?

TA的精华主题

TA的得分主题

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

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

TA的精华主题

TA的得分主题

 楼主| 发表于 2020-1-13 15:14 | 显示全部楼层
zpy2 发表于 2020-1-13 14:27
("\\171.20.241.1\
这个是内网的文件夹,速度慢,是不是网络的原因,如果换成本地文件夹是不是会快一点?

版主调整后还是很快的

TA的精华主题

TA的得分主题

发表于 2020-1-13 20:43 | 显示全部楼层
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
这样修改看看是否可行吧

评分

参与人数 1鲜花 +2 收起 理由
shcw007 + 2 感谢帮助

查看全部评分

TA的精华主题

TA的得分主题

 楼主| 发表于 2020-1-14 09:30 | 显示全部楼层
liulang0808 发表于 2020-1-13 20:43
Sub Getfd(ByVal pth, fso)
    Set ff = fso.getfolder(pth)
    For Each f In ff.Files

谢谢大大,可行
您需要登录后才可以回帖 登录 | 免费注册

本版积分规则

关注官方微信,每天学会一个新技能

手机版|关于我们|联系我们|ExcelHome

GMT+8, 2020-4-9 06:39 , Processed in 1.092614 second(s), 34 queries , Gzip On.

Powered by Discuz! X3.4

© 1999-2020 Wooffice Inc.

   

沪公网安备 31011702000001号 沪ICP备11019229号

本论坛言论纯属发表者个人意见,任何违反国家相关法律的言论,本站将协助国家相关部门追究发言者责任!     本站特聘法律顾问:徐怀玉律师 李志群律师

快速回复 返回顶部 返回列表