怎样用宏批量超链接!

战战如疯

zhaogang1960 发表于 2012-12-6 13:03
你得先告诉我下图中的前4列数据是从哪里来的，从文件夹“分公司-文件1”和文件9999.txt中无法获得

GetAttr(MyPath & MyName) And vbDirectory) = vbDirectory 这句为什么要用and?我把And vbDirectory) 去了好像也没有影响。这句是用来判断是不是文件夹的吧？属性是vbdirectory就可以判断是文件夹？

无限趋向

zhaogang1960 发表于 2012-12-6 13:03
你得先告诉我下图中的前4列数据是从哪里来的，从文件夹“分公司-文件1”和文件9999.txt中无法获得

老师.第四列数据是手工写的.以前做都是加好前四列.再逐个去找链接路径.现在想能不能去找包含第四项名称的文件去.不会有重名称文件.例如,那个路径下只有一个包含文件1的文件或文件夹.不知道请教明白没有,还请老师帮忙啊.

战战如疯

关于我的问题在书上找到答案了，一个点和两个点分别代表当前文件夹和上层文件夹{:soso_e128:}

zhaogang1960

无限趋向 发表于 2012-12-6 14:11
老师.第四列数据是手工写的.以前做都是加好前四列.再逐个去找链接路径.现在想能不能去找包含第四项名称的 ...

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.             b = Split(s, "-")
    
18.             t = d(b(UBound(b)))
    
19.             If t <> "" Then .Hyperlinks.Add Anchor:=Cells(t, 10), Address:=arrf(i)
    
20.         Next
    
21.     End With
    
22.     Set Fso = Nothing
    
23.     Application.ScreenUpdating = True
    
24. End Sub
    
25. 
    
26. Private Sub GetFolders(ByVal sPath$, Fso As Object, ByRef arrf$(), ByRef mf&)
    
27.     Dim Folder As Object
    
28.     Dim SubFolder As Object
    
29.     Set Folder = Fso.GetFolder(sPath)
    
30.     mf = mf + 1
    
31.     ReDim Preserve arrf(1 To mf)
    
32.     arrf(mf) = sPath
    
33.     If Folder.SubFolders.Count > 0 Then
    
34.         For Each SubFolder In Folder.SubFolders
    
35.             Call GetFolders(SubFolder.Path, Fso, arrf, mf)
    
36.         Next
    
37.     End If
    
38.     Set Folder = Nothing
    
39.     Set SubFolder = Nothing
    
40. End Sub
    
41. 
    

复制代码

zhaogang1960

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

2012-12-6 16:56 上传

点击文件名下载附件

zhaogang1960

chengyu92102 发表于 2012-12-6 12:59
想自动生成如附件中的目录
文件名有日文，特殊字符

请测试:

1. Dim ary(), m&
   
2. 
   
3. Sub Macro1()
   
4.     Dim s, a, cel, b, arr, brr(), n&, i&, l&
   
5.     s = Array("┃  ┣", "┃  ┃  ┣", "┃  ┃  ┃  ┣", "┃  ┃  ┃  ┃  ┣", "┃  ┃  ┃  ┃  ┃  ┣")
   
6.     Application.ScreenUpdating = False
   
7.     m = 2
   
8.     ReDim ary(1 To m)
   
9.     ary(1) = ThisWorkbook.Path & ""
   
10.     l = UBound(Split(ary(1), ""))
    
11.     i = 1
    
12.     Do While ary(i) <> ""
    
13.         dirdir (ary(i))
    
14.         If i > 1 Then
    
15.             n = n + 1
    
16.             ReDim Preserve brr(1 To 2, 1 To n)
    
17.             brr(1, n) = ary(i)
    
18.             brr(2, n) = Split(ary(i), "")(l)
    
19.         End If
    
20.         i = i + 1
    
21.     Loop
    
22.     With [z1].Resize(n, 2)
    
23.         .Value = WorksheetFunction.Transpose(brr)
    
24.         .Sort Key1:=Range("AA1"), Order1:=xlAscending
    
25.         arr = .Value
    
26.         .Clear
    
27.     End With
    
28.     n = 1
    
29.     [A1].CurrentRegion.Clear
    
30.     [A1] = "┣" & Split(ThisWorkbook.Name, ".")(0)
    
31.     With ActiveSheet
    
32.         For i = 1 To UBound(arr)
    
33.             n = n + 1
    
34.             a = Split(arr(i, 1), "")
    
35.             Cells(n, 1) = s(UBound(a) - l - 1) & a(UBound(a) - 1)
    
36.             MyFilename = Dir(arr(i, 1) & "*.*")
    
37.             Do While MyFilename <> ""
    
38.                 n = n + 1
    
39.                 .Hyperlinks.Add Anchor:=.Cells(n, 1), Address:=arr(i, 1) & MyFilename, TextToDisplay:=s(UBound(a) - l) & MyFilename
    
40.                 MyFilename = Dir
    
41.             Loop
    
42.         Next
    
43.     End With
    
44.     m = 0
    
45.     Erase ary
    
46.     Application.ScreenUpdating = True
    
47.     MsgBox "完毕"
    
48. End Sub
    
49. 
    
50. Sub dirdir(MyPath)
    
51.     Dim MyName
    
52.     MyName = Dir(MyPath, vbDirectory)
    
53.     Do While MyName <> ""
    
54.         If MyName <> "." And MyName <> ".." Then
    
55.             If (GetAttr(MyPath & MyName) And vbDirectory) = vbDirectory Then
    
56.                 m = m + 1
    
57.                 ReDim Preserve ary(1 To m)
    
58.                 ary(m - 1) = MyPath & MyName & ""
    
59.             End If
    
60.         End If
    
61.         MyName = Dir
    
62.     Loop
    
63. End Sub
    
64. 
    
65. 
    
66. 
    
67. 
    
68. 
    

复制代码

zhaogang1960

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

2012-12-6 17:12 上传

点击文件名下载附件

无限趋向

zhaogang1960 发表于 2012-12-6 16:55

多谢zhaogang1960  老师的帮助. 不过,还有一些地方没有实现效果,文件3,文件11 ,这样的没有链接上,这个链接的目标文件夹中包含这样的文件,但不完全相等,当然,不会重复. 另外,最重要的.文件12,文件13,文件15 这样直接链到文件而不是目录上的能做到吗?

zhaogang1960

无限趋向 发表于 2012-12-7 08:57
多谢zhaogang1960  老师的帮助. 不过,还有一些地方没有实现效果,文件3,文件11 ,这样的没有链接上,这个链 ...

我没有理解，请上传附件说明

chengyu92102

请老师帮看一下，在目录的第二个工作表里写了自己想要的样子，谢谢了