|
|
[广告] VBA代码宝 - VBA编程加强工具 · VBA代码随查随用 · 内置多项VBA编程加强工具 ★ 免费下载 ★ ★ 使用手册★
回复 54楼 walkenbach 的帖子
经查看得知带有“-”的工作表名超链中会在两边都加上“'”撇号，文件名只是个显示问题，在前面加上一个“'”撇号就可以了：
Dim ary(), m As Integer
Sub TQML()
'BY E.H. ZhaoGang1960
Dim MyPath$, myfile$, mydir$, n%, i%, sh As Worksheet, a, f%, c As Range, s$
a = Array("序号", "文件名", "日期")
If Not Selection Is Nothing Then
Set c = Selection
Else
Set c = Range("A1")
End If
Application.ScreenUpdating = False
Application.DisplayAlerts = False
For Each sh In Sheets
If sh.Name <> "总目录" Then sh.Delete
Next
MyPath = ThisWorkbook.Path & "\"
m = 2
ReDim ary(1 To 2, 1 To m)
ary(1, 1) = MyPath
i = 1
Do While ary(1, i) <> ""
dirdir (ary(1, i))
i = i + 1
Loop
myfile = Dir(MyPath & "*.*")
f = 1
With Sheets("总目录")
.UsedRange.Offset(1, 0).ClearContents
Do While myfile <> ""
If myfile <> ThisWorkbook.Name Then
f = f + 1
s = Split(myfile, ".")(0) '工作簿名
If InStr(s, "-") Then s = "'" & s '前面加上一个撇号
.Hyperlinks.Add Anchor:=.Cells(f, 2), Address:=MyPath & myfile, TextToDisplay:=s
End If
myfile = Dir
Loop
.Range("A2").Value = 1
End With
For i = 2 To m - 1
With Sheets.Add(After:=Sheets(Sheets.Count))
.Name = ary(2, i)
.Range("a1").Resize(1, 3) = a
End With
myfile = Dir(ary(1, i) & "*.*")
n = 1
With Sheets(ary(2, i))
.UsedRange.Offset(1, 0).ClearContents
Do While myfile <> ""
n = n + 1
.Hyperlinks.Add Anchor:=.Cells(n, 2), Address:=ary(1, i) & myfile, TextToDisplay:=Split(myfile, ".")(0)
myfile = Dir
Loop
If n > 1 Then .Range("A2").Value = 1
'.Range("A2").Value = 1
If n > 2 Then .Range("A2").AutoFill Destination:=.Range("A2").Resize(n - 1), Type:=xlFillSeries
If n > 1 Then .Range("C2").Resize(n - 1) = Date
'.Range("C2").Resize(n - 1) = Date
With .Range("A1").CurrentRegion
.HorizontalAlignment = xlCenter
.Borders.LineStyle = xlContinuous
.EntireColumn.AutoFit
End With
End With
Next
With Sheets("总目录")
For Each sh In Sheets
If sh.Name <> "总目录" Then
f = f + 1
s = sh.Name
If InStr(s, "-") Then s = "'" & s & "'" '前后都要加上一个撇号
.Hyperlinks.Add Anchor:=.Cells(f, 2), Address:="", SubAddress:=s & "!A1", TextToDisplay:=Left(s, Len(s) - 1)
End If
Next
If f > 2 Then .Range("A2").AutoFill Destination:=.Range("A2").Resize(f - 1), Type:=xlFillSeries
.Range("b65536").End(3).Offset(1).Copy
.Range("b2").Resize(f - 1).PasteSpecial Paste:=xlPasteFormats
Application.CutCopyMode = False
End With
Sheets(1).Activate
c.Select
m = 0
Erase ary
Application.ScreenUpdating = True
End Sub
Sub dirdir(MyPath)
Dim MyName
MyName = Dir(MyPath, vbDirectory)
Do While MyName <> ""
If MyName <> "." And MyName <> ".." Then
If (GetAttr(MyPath & MyName) And vbDirectory) = vbDirectory Then
m = m + 1
ReDim Preserve ary(1 To 2, 1 To m)
ary(1, m - 1) = MyPath & MyName & "\"
ary(2, m - 1) = MyName
End If
End If
MyName = Dir
Loop
End Sub
文件夹.rar
(100.7 KB, 下载次数: 751)
|
评分
-
1
查看全部评分
-
|
楼主: wangzhongtu
沪公网安备 31011702000001号 沪ICP备11019229号-2
发表于 2009-10-8 21:21
楼主
