怎样用宏批量超链接!

无限趋向

zhaogang1960 发表于 2012-12-7 17:23
请测试：

Sub Macro1()
    Dim Fso As Object, arr, a, b, s$, t, i&
    Dim arrf$(), mf&, d As Object
    Application.ScreenUpdating = False
    Set d = CreateObject("scripting.dictionary")
    arr = Range("E1:E" & Range("E65536").End(xlUp).Row)
    For i = 3 To UBound(arr)
        d(arr(i, 1)) = i
    Next
    Set Fso = CreateObject("Scripting.FileSystemObject")
    p = ThisWorkbook.Path & "\河北分公司制度目录"
    Call GetFolders(p, Fso, arrf, mf)
    With ActiveSheet
        For i = 1 To mf
            a = Split(arrf(i), "\")
            s = a(UBound(a))
            a = Split(s, "（")
            s = a(0)
            b = Split(s, "-")
            s = b(UBound(b))
            b = Split(s, ".")
            s = b(0)
            t = d(s)
            If t <> "" Then .Hyperlinks.Add Anchor:=Cells(t, 10), Address:=arrf(i)
        Next
    End With
    Set Fso = Nothing
    Application.ScreenUpdating = True
End Sub
Private Sub GetFolders(ByVal sPath$, Fso As Object, ByRef arrf$(), ByRef mf&)
    Dim Folder As Object
    Dim SubFolder As Object
    Set Folder = Fso.GetFolder(sPath)
    mf = mf + 1
    ReDim Preserve arrf(1 To mf)
    arrf(mf) = sPath
    For Each File In Folder.Files
            mf = mf + 1
            ReDim Preserve arrf(1 To mf)
            arrf(mf) = sPath & "\" & File.Name
    Next
    If Folder.SubFolders.Count > 0 Then
        For Each SubFolder In Folder.SubFolders
            Call GetFolders(SubFolder.Path, Fso, arrf, mf)
        Next
    End If
    Set Folder = Nothing
    Set SubFolder = Nothing
End Sub


用了很好用. 真想学习一下啊.但VBA懂得非常少.  哪位老师能给解释一下这段代码吗

zhaogang1960

无限趋向 发表于 2012-12-11 15:37
Sub Macro1()
    Dim Fso As Object, arr, a, b, s$, t, i&
    Dim arrf$(), mf&, d As Object

1. Sub Macro1() '主程序
   
2.      Dim Fso As Object, arr, a, b, s$, t, i& '声明变量,下同
   
3.      Dim arrf$(), mf&, d As Object
   
4.      Application.ScreenUpdating = False '禁止屏幕刷新
   
5.      Set d = CreateObject("scripting.dictionary") '创建字典对象
   
6.      arr = Range("E1:E" & Range("E65536").End(xlUp).Row) 'E列数据写入数组
   
7.      For i = 3 To UBound(arr) '逐行
   
8.          d(arr(i, 1)) = i '用字典把E列内容和行号关联起来
   
9.      Next
   
10.      Set Fso = CreateObject("Scripting.FileSystemObject") '创建Fso对象
    
11.      p = ThisWorkbook.Path & "\河北分公司制度目录" '路径
    
12.      Call GetFolders(p, Fso, arrf, mf) '调用GetFolders子程序
    
13.      With ActiveSheet '当前工作表
    
14.          For i = 1 To mf '逐个文件或文件夹
    
15.              a = Split(arrf(i), "") '""分开
    
16.              s = a(UBound(a)) '最后一个
    
17.              a = Split(s, "（") '再用"（"分开
    
18.              s = a(0) '第一个
    
19.              b = Split(s, "-") '再用"-"分开
    
20.              s = b(UBound(b)) '最后一个
    
21.              b = Split(s, ".") '再用"."分开
    
22.              s = b(0) '第一个
    
23.              t = d(s) '求出该字符串在E列的行号
    
24.              If t <> "" Then .Hyperlinks.Add Anchor:=Cells(t, 10), Address:=arrf(i) '如果这个行号存在，则创建超级链接
    
25.          Next
    
26.      End With
    
27.      Set Fso = Nothing '释放内存
    
28.      Application.ScreenUpdating = True '开启屏幕刷新
    
29. End Sub
    
30. Private Sub GetFolders(ByVal sPath$, Fso As Object, ByRef arrf$(), ByRef mf&) '求出子文件夹和子文件的子程序
    
31.      Dim Folder As Object
    
32.      Dim SubFolder As Object
    
33.      Set Folder = Fso.GetFolder(sPath)
    
34.      mf = mf + 1
    
35.      ReDim Preserve arrf(1 To mf)
    
36.      arrf(mf) = sPath '子文件夹写入数组
    
37.      For Each File In Folder.Files
    
38.         mf = mf + 1
    
39.         ReDim Preserve arrf(1 To mf)
    
40.         arrf(mf) = sPath & "" & File.Name '子文件写入数组
    
41.      Next
    
42.      If Folder.SubFolders.Count > 0 Then '如果还有子文件夹，则再调用本子程序(递归)
    
43.          For Each SubFolder In Folder.SubFolders
    
44.              Call GetFolders(SubFolder.Path, Fso, arrf, mf)
    
45.          Next
    
46.      End If
    
47.      Set Folder = Nothing
    
48.      Set SubFolder = Nothing
    
49. End Sub
    

复制代码

无限趋向

zhaogang1960 发表于 2012-12-11 16:44

太感谢老师的耐心指导了。再请教您。代码中的这部分：
With ActiveSheet '当前工作表
         For i = 1 To mf '逐个文件或文件夹
             a = Split(arrf(i), "\") '"\"分开
             s = a(UBound(a)) '最后一个
             a = Split(s, "（") '再用"（"分开
             s = a(0) '第一个
             b = Split(s, "-") '再用"-"分开
             s = b(UBound(b)) '最后一个
             b = Split(s, ".") '再用"."分开
             s = b(0) '第一个
         

是把每个文件夹都拆解成E列可能有的部分了。如果我不拆解，或者只拆到这一步：
For i = 1 To mf '逐个文件或文件夹
             a = Split(arrf(i), "\") '"\"分开
             s = a(UBound(a)) '最后一个

然后判断s 中是否包含E列中的某一个值，能否实现。
比如：拆解完 s="2012年费用政策讲解"   而E12单元格为   “费用政策讲解” ，只要判断出E12是包含当前路径值的，则建立链接，能做到吗？

zhaogang1960

无限趋向 发表于 2012-12-14 23:14
太感谢老师的耐心指导了。再请教您。代码中的这部分：
With ActiveSheet '当前工作表
         For i ...

这都是根据你的奇特要求写出来的，不要再变化了，否则就乱套了，代码没有那么聪明

幽幽1983

感谢zhaogang1960 ，找这个很久了

幽幽1983

太强大了，谢谢

幽幽1983

我的出现问题了

wd815

这个留纪念了。实用

qinhuan66

zhaogang1960 发表于 2012-12-7 17:01
请看附件

赵老师我是你的忠实粉丝。你的这个附件做得太好了。能否在B列列数每个文件夹里面有多少个文件呢。谢谢

法律法规原文.rar (268.4 KB, 下载次数: 67)

2014-1-25 10:34 上传

点击文件名下载附件

如图：黄色区域

fhqlrwgss

mark......................