|
|
回复 34楼 高玉甫 的帖子
请测试:
Private Sub Workbook_Open()
Dim mypath$, myfile$, mydir$, arr() As String, m%, n%, i%, sh As Worksheet, a
a = Array("序号", "文件名", "日期")
Application.ScreenUpdating = False
mypath = ThisWorkbook.Path & "\"
mydir = Dir(mypath & "*", vbDirectory)
While mydir > ""
If Not mydir Like ".*" And GetAttr(mypath & mydir) = vbDirectory Then
n = n + 1
ReDim Preserve arr(1 To 2, 1 To n)
arr(1, n) = mypath & mydir & "\"
arr(2, n) = mydir
End If
mydir = Dir()
Wend
On Error Resume Next
For i = 1 To n
Set sh = Sheets(arr(2, i))
If sh Is Nothing Then
With Sheets.Add(After:=Sheets(Sheets.Count))
.Name = arr(2, i)
.Range("a1").Resize(1, 3) = a
End With
End If
Set sh = Nothing
myfile = Dir(arr(1, i) & "*.*")
m = 1
With Sheets(arr(2, i))
.UsedRange.Offset(1, 0).Clear
Do While myfile <> ""
m = m + 1
.Hyperlinks.Add Anchor:=.Cells(m, 2), Address:=arr(1, i) & myfile, TextToDisplay:=Split(myfile, ".")(0)
myfile = Dir
Loop
.Range("A2").Value = 1
If m > 2 Then .Range("A2").AutoFill Destination:=.Range("A2").Resize(m - 1), Type:=xlFillSeries
.Range("C2").Resize(m - 1) = Date
With .Range("A1").CurrentRegion
.HorizontalAlignment = xlCenter
.Borders.LineStyle = xlContinuous
End With
End With
Next
Sheets(1).Activate
Application.ScreenUpdating = True
End Sub |
|
楼主: wangzhongtu
沪公网安备 31011702000001号 沪ICP备11019229号-2
发表于 2009-10-6 09:27
