博客

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