VBA各种超链接代码

功能：
遍历指定路径中的文件夹，并在当前工作表中添加超链接

Sub chiefzjh1()
Dim i%, r%, mFdr$, mPth$, aDrs()
r = 1
mpath = "h:\"
mFdr = Dir(mpath, vbDirectory)
Do While mFdr <> ""
If mFdr <> "." And mFdr <> ".." Then
If GetAttr(mpath & mFdr) = 16 Then 'folder=16,file=32
ReDim Preserve aDrs(1 To r)
aDrs(r) = mpath & mFdr
r = r + 1
End If
End If
mFdr = Dir
Loop
With ActiveSheet
For i = 1 To r - 1
.Hyperlinks.Add anchor:=.Cells(i, 1), Address:=aDrs(i)
Next i
End With
Erase aDrs
End Sub
**********Remark***************
常数 值 描述
vbNormal 0 常规
vbReadOnly 1 只读
vbHidden 2 隐藏
vbSystem 4 系统文件
vbDirectory 16 目录或文件夹
vbArchive 32 上次备份以后，文件已经改变
vbalias 64 指定的文件名是别名。
======================================
======================================
功能：
遍历本路径中的文件，并在当前工作表1A列中添加超链接
Sub chiefzjh2()
Dim mNm$, mPth$, dic, r%
Set dic = CreateObject("scripting.dictionary")
mPth = "c:\"
mNm = Dir(mPth & "*.*")
Do While mNm <> ""
If GetAttr(mPth & mNm) = 32 Then dic.Add mNm, ""
mNm = Dir
Loop
[a1].Resize(dic.Count, 1) = WorksheetFunction.Transpose(dic.keys)
With Sheet1
For r = 1 To dic.Count
.Hyperlinks.Add anchor:=Cells(r, 1), Address:=mPth & .Cells(r, 1).Text
Next
End With
End Sub
======================================
======================================

功能：
遍历本工作簿中所有工作表，并在当前工作表1A列中添加超链接
Sub chiefzjh3()
With Sheet1
[a1] = "Sheets Link:"
For i% = 2 To Worksheets.Count
.Hyperlinks.Add anchor:=Cells(i, 1), Address:="", _
SubAddress:=Sheets(i).Name & "!a1", TextToDisplay:=Sheets(i).Name
Next i
End With
End Sub
======================================
======================================
功能：
更改数据有效性设置后，把有效性不规范的单元格地址在表2中写出来，
并超链接

'活动单元格先定位于含有有效性的单元格，再运行这段宏，以取得有效性内容
Sub chiefzjh4()
Application.ScreenUpdating = False
Dim tSt$, i%, mC%, r%, Sht$, mAdd(), mFml$
mC = ActiveCell.Column
Sht =
tSt = ActiveCell.Validation.Formula1
For i = 1 To ActiveCell.End(xlDown).Row
If InStr(tSt, Cells(i, mC).Text) = 0 Then
r = r + 1
ReDim Preserve mAdd(1 To r)
mAdd(r) = Cells(i, mC).Address(0, 0)
End If
Next i
'结果输出到sheet2 A列，从第一行开始，自行修改
Sheet2.Activate
Columns(1).ClearContents
With ActiveSheet
For i = 1 To r
.Hyperlinks.Add Anchor:=.Cells(i, 1), Address:="", _
SubAddress:=Sht & "!" & mAdd(i), TextToDisplay:=mAdd(i)
Next i
End With
Application.ScreenUpdating = True
End Sub