|
除非注明，文章均为 战战如疯 原创，转载请保留链接: http://www./cat4/157.html，VBA交流群273624828。
今天我们再来讲一个利用Excel做超链接目录的例子。假设你是公司的一个人事，手上有公司上下几百号人的电子资料，都是word格式。你这些资料呢都是分部分放在不同的文件夹里的，平时查看起来可能觉得不是很方便。现在你有一个想法，要在一个Excel表格里将所有员工的名字全都列出来，并且全都加上指上相应文件的超链接，手头完成肯定是不太现实了，那么现在我们看用Excel VBA怎么来解决这个问题。
现在我们手上有如文章末尾示例文件所示的两个部门文件夹，每个文件夹中都有若干word形式的员工资料，我们在同一路径下新建一个Excel表格，打开VBA编辑界面输入如下代码：
Sub 创建目录()
Dim arr(), brr(), crr(), i, j, k, m, mypath, mydir, myfile
'首先遍历路径下所有的文件夹并将所有路径记入数组arr中
mypath = ThisWorkbook.Path & "\"
mydir = Dir(mypath, vbDirectory)
Do While mydir <> ""
If mydir <> "." And mydir <> ".." Then
If GetAttr(mypath & mydir) = vbDirectory Then
j = j + 1
ReDim Preserve arr(1 To j)
arr(j) = mypath & mydir & "\"
End If
End If
mydir = Dir
Loop
'下面循环遍历每个文件夹中的word文件，将每个word文件的路径记入数组brr中，名称记入数组crr中
For i = 1 To UBound(arr)
myfile = Dir(arr(i) & "*.docx")
Do While myfile <> ""
k = k + 1
ReDim Preserve brr(1 To k), crr(1 To k)
brr(k) = arr(i) & myfile
crr(k) = myfile
myfile = Dir
Loop
Next
'加超链接
For m = 1 To UBound(brr)
ActiveSheet.Hyperlinks.Add Anchor:=Cells(m, 1), Address:=brr(m), TextToDisplay:=crr(m)
Next
End Sub
上述代码的思路很简单，先利用Dir方法遍历该路径下的所有文件夹，将路径放入一个数组中记录下来，之后对数组中每一个文件夹路径进行Dir遍历，将每个文件夹中的word文件路径和名称也分别记下来。Dir方法我在这里就不再讲了，可以参见利用Dir函数遍历某文件夹下的所有文件和多个文件夹中的Excel工作簿汇总到一个表中。添加超链接用的是Hyperlinks.Add函数，其中几个比较重要的参数Anchor是放置超链接的单元格位置，Address自然是超链接的链接地址，TextToDisplay字面理解就是要显示的文字了，用一个For循环就可以实现将所有的文件加上超链接了。
需要注意的是这种方法生成的超链接是相对路径的，即Excel和资料文件夹的相对位置不能变，你可以将整个文件夹都复制到另一个地方去用，但是不能只把Excel工作簿复制到另外的地方去用，这样会提示找不到路径的错误。那么怎么来创建绝对路径的超链接以便我的Excel放到其它地方也能使用呢，怎么用Hyperlinks.Add我还没有查到，不过我们可以换用工作表公式Hyperlinks来完成，下面是示例代码
Sub 创建目录2() '绝对路径
Dim arr(), brr(), crr(), i, j, k, m, mypath, mydir, myfile
Columns(1).Clear
'首先遍历路径下所有的文件夹并将所有路径记入数组arr中
mypath = ThisWorkbook.Path & "\"
mydir = Dir(mypath, vbDirectory)
Do While mydir <> ""
If mydir <> "." And mydir <> ".." Then
If GetAttr(mypath & mydir) = vbDirectory Then
j = j + 1
ReDim Preserve arr(1 To j)
arr(j) = mypath & mydir & "\"
End If
End If
mydir = Dir
Loop
'下面循环遍历每个文件夹中的word文件，将每个word文件的路径记入数组brr中，名称记入数组crr中
For i = 1 To UBound(arr)
myfile = Dir(arr(i) & "*.docx")
Do While myfile <> ""
k = k + 1
ReDim Preserve brr(1 To k), crr(1 To k)
brr(k) = arr(i) & myfile
crr(k) = myfile
myfile = Dir
Loop
Next
'加超链接
For m = 1 To UBound(brr)
Cells(m, 1).Formula = "=Hyperlink(" & """" & brr(m) & """" & "," & """" & crr(m) & """" & ")"
Next
End Sub
Cells(m, 1).Formula = "=Hyperlink(" & """" & brr(m) & """" & "," & """" & crr(m) & """" & ")"就是将相应单元格中输入公式，例如cells(1,1).formula="=1+1"则会在A1单元格中输入“=1+1”这个公式，和你手动在A1输入是一样的效果，感兴趣的朋友可以研究一下这里的公式为什么这么写。
本节示例文件下载http://pan.baidu.com/s/1nt0scUd。
|
