VBA实现超链接

VBA 同时被 2 个专栏收录
8 篇文章 0 订阅
27 篇文章 0 订阅

vb中提供的成员函数dir:返回一个满足指定类型或指定文件属性的文件名,目录名或卷标名。
dir函数的语法结构为:Member Function Dir[(Pathname[,attributes])] As String 
其中参数Pathname通常为一个文件名,此文件名可以包含目录或文件夹以及驱动器符号,如果没有找到指定的Pathname,dir语句将返回一个零长度的字符串("")。
支持多字符通配符和单字符通配符.需要注意的是 
1.在程序中第一次调用dir函数时必须指明pathname参数,否则会产生运行错误;
2.dir函数只返回满足pathname条件的第一个文件名或目录名,要得到其余满足条件的文件名,可以再次调用dir函数而不用带参数,当没有匹配的文件,dir函数返回零长度的字符串,而此时如果再想调用dir函数,必须指定pathname参数,否则出现运行错误;
3.在没有检索到满足当前pathname匹配条件的文件时可以改变新的pathname值,但不能再次递归调用dir函数;
4.调用dir函数时将属性参数设置为vbdirectory并不能连续返回子目录,仅返回当前目录下的目录. 

VBA自定义模块,excel表中,实现为指定目录下的文档形成一个链接目录。

这个是可以的,适用公司使用。

Sub dssd()


Dim sr$, sr1$, n%, m%, i%, j%, aa%
j = ThisWorkbook.Worksheets.Count
On Error Resume Next

For i = 1 To j
MsgBox (i)
m = 0
ThisWorkbook.Sheets(i).Activate
Columns("c:c").Select
Selection.Hyperlinks.Delete


'MsgBox (Sheets(i).Name)




Do
m = m + 1
ss = Cells(m + 3, 3).Text
sr1 = Dir(ThisWorkbook.Path & "\现行制度-" & Sheets(i).Name & "\*.*")
'MsgBox (sr1)

Do
aa = InStr(sr1, ss)
'MsgBox (aa)
If (aa > 0 And Len(ss) > 3) Then Sheets(i).Hyperlinks.Add Cells(m + 3, 3), ThisWorkbook.Path & "\现行制度-" & Sheets(i).Name & "\" & sr1
'MsgBox (ss)
'MsgBox (sr1)
sr1 = Dir
Loop Until Len(sr1) < 3

Loop Until Len(Cells(m + 3, 3)) < 3



Columns("C:C").Select
With Selection.Font
.Underline = xlUnderlineStyleNone
End With
Columns("c:c").unselect

Next

End Sub



 

 

 

Sub dssd()

Sheet2.Activate
'MsgBox (Sheet2.Name)
Dim sr$, sr1$, n%, m%, aa%
sr = Dir(ThisWorkbook.Path & "\现行制度-" & Sheet2.Name & "\*.*")
'MsgBox (sr)
'MsgBox (Dir)
'MsgBox (ThisWorkbook.Path)
Range("g3:h888").ClearComments
On Error Resume Next

Do
n = n + 1
Cells(n + 3, 7) = n
Cells(n + 3, 8) = sr
Sheet2.Hyperlinks.Add Cells(n + 3, 8), ThisWorkbook.Path & "\现行制度-社保\" & sr
sr = Dir
Loop Until sr = ""


Columns("H:H").Select
With Selection.Font
.Underline = xlUnderlineStyleNone
End With

Do
m = m + 1
ss = Cells(m + 3, 3).Text
sr1 = Dir(ThisWorkbook.Path & "\现行制度-" & Sheet2.Name & "\*.*")

Do
aa = InStr(sr1, ss)
MsgBox (aa)
If aa > 0 Then Sheet2.Hyperlinks.Add Cells(m + 3, 3), ThisWorkbook.Path & "\现行制度-社保\" & sr1
'MsgBox (ss)
'MsgBox (sr1)
sr1 = Dir
Loop Until sr1 = ""



Loop Until len(Cells(m + 3, 3) ) >5

Columns("c:c").Select
With Selection.Font
.Underline = xlUnderlineStyleNone
End With

End Sub



 

 

 

  • 1
    点赞
  • 1
    评论
  • 4
    收藏
  • 一键三连
    一键三连
  • 扫一扫,分享海报

©️2021 CSDN 皮肤主题: 技术工厂 设计师:CSDN官方博客 返回首页
实付
使用余额支付
点击重新获取
扫码支付
钱包余额 0

抵扣说明:

1.余额是钱包充值的虚拟货币,按照1:1的比例进行支付金额的抵扣。
2.余额无法直接购买下载,可以购买VIP、C币套餐、付费专栏及课程。

余额充值