除非注明，文章均為 戰(zhàn)戰(zhàn)如瘋 原創(chuàng)，轉(zhuǎn)載請保留鏈接: http://www./cat4/157.html，VBA交流群273624828。

今天我們再來講一個(gè)利用Excel做超鏈接目錄的例子。假設(shè)你是公司的一個(gè)人事，手上有公司上下幾百號人的電子資料，都是word格式。你這些資料呢都是分部分放在不同的文件夾里的，平時(shí)查看起來可能覺得不是很方便?，F(xiàn)在你有一個(gè)想法，要在一個(gè)Excel表格里將所有員工的名字全都列出來，并且全都加上指上相應(yīng)文件的超鏈接，手頭完成肯定是不太現(xiàn)實(shí)了，那么現(xiàn)在我們看用Excel VBA怎么來解決這個(gè)問題。

現(xiàn)在我們手上有如文章末尾示例文件所示的兩個(gè)部門文件夾，每個(gè)文件夾中都有若干word形式的員工資料，我們在同一路徑下新建一個(gè)Excel表格，打開VBA編輯界面輸入如下代碼：

Sub 創(chuàng)建目錄()
Dim arr(), brr(), crr(), i, j, k, m, mypath, mydir, myfile
'首先遍歷路徑下所有的文件夾并將所有路徑記入數(shù)組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
'下面循環(huán)遍歷每個(gè)文件夾中的word文件，將每個(gè)word文件的路徑記入數(shù)組brr中，名稱記入數(shù)組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方法遍歷該路徑下的所有文件夾，將路徑放入一個(gè)數(shù)組中記錄下來，之后對數(shù)組中每一個(gè)文件夾路徑進(jìn)行Dir遍歷，將每個(gè)文件夾中的word文件路徑和名稱也分別記下來。Dir方法我在這里就不再講了，可以參見利用Dir函數(shù)遍歷某文件夾下的所有文件和多個(gè)文件夾中的Excel工作簿匯總到一個(gè)表中。添加超鏈接用的是Hyperlinks.Add函數(shù)，其中幾個(gè)比較重要的參數(shù)Anchor是放置超鏈接的單元格位置，Address自然是超鏈接的鏈接地址，TextToDisplay字面理解就是要顯示的文字了，用一個(gè)For循環(huán)就可以實(shí)現(xiàn)將所有的文件加上超鏈接了。

需要注意的是這種方法生成的超鏈接是相對路徑的，即Excel和資料文件夾的相對位置不能變，你可以將整個(gè)文件夾都復(fù)制到另一個(gè)地方去用，但是不能只把Excel工作簿復(fù)制到另外的地方去用，這樣會提示找不到路徑的錯(cuò)誤。那么怎么來創(chuàng)建絕對路徑的超鏈接以便我的Excel放到其它地方也能使用呢，怎么用Hyperlinks.Add我還沒有查到，不過我們可以換用工作表公式Hyperlinks來完成，下面是示例代碼

Sub 創(chuàng)建目錄2()  '絕對路徑
Dim arr(), brr(), crr(), i, j, k, m, mypath, mydir, myfile
Columns(1).Clear
'首先遍歷路徑下所有的文件夾并將所有路徑記入數(shù)組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
'下面循環(huán)遍歷每個(gè)文件夾中的word文件，將每個(gè)word文件的路徑記入數(shù)組brr中，名稱記入數(shù)組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) & """" & ")"就是將相應(yīng)單元格中輸入公式，例如cells(1,1).formula="=1+1"則會在A1單元格中輸入“=1+1”這個(gè)公式，和你手動在A1輸入是一樣的效果，感興趣的朋友可以研究一下這里的公式為什么這么寫。

本節(jié)示例文件下載http://pan.baidu.com/s/1nt0scUd。