怎样用宏批量超链接!

chengyu92102

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

老师，辛苦了，非常感谢，真的非常感谢，但有一点问题，新加入一个文件夹，这个文件夹生成的目录，文件夹从属关系不太正确，请再帮忙看一下好吗，谢谢了，附件放在90楼，目录的第二个工作表写了想要的样子，谢谢了，帮看一下。

zhaogang1960

chengyu92102 发表于 2012-12-7 10:55
老师，辛苦了，非常感谢，真的非常感谢，但有一点问题，新加入一个文件夹，这个文件夹生成的目录，文件夹 ...

使用Dir函数需要排序，估计是排序出问题了，下午再用Fso试试

chengyu92102

zhaogang1960 发表于 2012-12-7 12:42
使用Dir函数需要排序，估计是排序出问题了，下午再用Fso试试

谢谢，辛苦了

无限趋向

zhaogang1960 发表于 2012-12-7 10:02
我没有理解，请上传附件说明

老师,上传了问题附件.请再帮忙看一下.多谢了!

zhaogang1960

chengyu92102 发表于 2012-12-7 13:00
谢谢，辛苦了

Fso法请测试:

1. Dim Fso As Object, d As Object
   
2. 
   
3. Sub Macro1()
   
4.     Dim i&, j&, n&, s, a, l&, k, k2
   
5.     s = Array("┃  ┣", "┃  ┃  ┣", "┃  ┃  ┃  ┣", "┃  ┃  ┃  ┃  ┣", "┃  ┃  ┃  ┃  ┃  ┣")
   
6.     Application.ScreenUpdating = False
   
7.     Set Fso = CreateObject("Scripting.FileSystemObject")
   
8.     Set d = CreateObject("scripting.dictionary")
   
9.     Call GetFiles(ThisWorkbook.Path)
   
10.     l = UBound(Split(ThisWorkbook.Path & "", ""))
    
11.     k = d.keys
    
12.     [a:a].Clear
    
13.     [a1] = "┣" & Split(ThisWorkbook.Name, ".")(0)
    
14.     n = 1
    
15.     With ActiveSheet
    
16.         For i = 1 To d.Count - 1
    
17.             n = n + 1
    
18.             a = Split(k(i), "")
    
19.             Cells(n, 1) = s(UBound(a) - l) & a(UBound(a))
    
20.             k2 = d(k(i)).keys
    
21.             For j = 0 To UBound(k2)
    
22.                 n = n + 1
    
23.                 .Hyperlinks.Add Anchor:=.Cells(n, 1), Address:=k(i) & "" & k2(j), TextToDisplay:=s(UBound(a) - l + 1) & k2(j)
    
24.             Next
    
25.         Next
    
26.     End With
    
27.     Set Fso = Nothing
    
28.     Set d = Nothing
    
29.     Application.ScreenUpdating = True
    
30. End Sub
    
31. 
    
32. Private Sub GetFiles(ByVal sPath$)
    
33.     Dim Folder As Object
    
34.     Dim SubFolder As Object
    
35.     Dim File As Object
    
36.     Set Folder = Fso.GetFolder(sPath)
    
37.     Set d(sPath) = CreateObject("scripting.dictionary")
    
38.     For Each File In Folder.Files
    
39.         d(sPath)(File.Name) = ""
    
40.     Next
    
41.     If Folder.SubFolders.Count > 0 Then
    
42.         For Each SubFolder In Folder.SubFolders
    
43.             Call GetFiles(SubFolder.Path)
    
44.         Next
    
45.     End If
    
46.     Set Folder = Nothing
    
47.     Set File = Nothing
    
48.     Set SubFolder = Nothing
    
49. End Sub
    
50. 
    

复制代码

zhaogang1960

请看附件
01 法律法规原文.rar (273.55 KB, 下载次数: 317)

2012-12-7 17:01 上传

点击文件名下载附件

zhaogang1960

无限趋向 发表于 2012-12-7 13:20
老师,上传了问题附件.请再帮忙看一下.多谢了!

请测试：

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)
   
7.     For i = 3 To UBound(arr)
   
8.         d(arr(i, 1)) = i
   
9.     Next
   
10.     Set Fso = CreateObject("Scripting.FileSystemObject")
    
11.     p = ThisWorkbook.Path & "\河北分公司制度目录"
    
12.     Call GetFolders(p, Fso, arrf, mf)
    
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)
    
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. 
    
31. Private Sub GetFolders(ByVal sPath$, Fso As Object, ByRef arrf$(), ByRef mf&)
    
32.     Dim Folder As Object
    
33.     Dim SubFolder As Object
    
34.     Set Folder = Fso.GetFolder(sPath)
    
35.     mf = mf + 1
    
36.     ReDim Preserve arrf(1 To mf)
    
37.     arrf(mf) = sPath
    
38.     For Each File In Folder.Files
    
39.             mf = mf + 1
    
40.             ReDim Preserve arrf(1 To mf)
    
41.             arrf(mf) = sPath & "" & File.Name
    
42.     Next
    
43.     If Folder.SubFolders.Count > 0 Then
    
44.         For Each SubFolder In Folder.SubFolders
    
45.             Call GetFolders(SubFolder.Path, Fso, arrf, mf)
    
46.         Next
    
47.     End If
    
48.     Set Folder = Nothing
    
49.     Set SubFolder = Nothing
    
50. End Sub
    
51. 
    

复制代码

zhaogang1960

请看附件
VBA批量建立链接.rar (380.07 KB, 下载次数: 738)

2012-12-7 17:23 上传

点击文件名下载附件

chengyu92102

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

可以了，谢谢老师，非常感谢

无限趋向

感激涕零!!