|
- Option Explicit
- Dim arr(), l As Integer
- Function fld(Path As String)
- Dim fso As Object
- Dim f As Object
- Dim fd As Object
- Dim subf As Object
- Set fso = CreateObject("scripting.FileSystemObject")
- Set fd = fso.GetFolder(Path)
- For Each f In fd.Files
- l = l + 1
- ReDim Preserve arr(1 To l)
- arr(l) = f.Path
- Next
- For Each subf In fd.SubFolders
- fld (subf.Path)
- Next
- End Function
- Sub test()
- Dim sh As Worksheet, Myname$
- Dim brr(1 To 60000, 1 To 5), crr As Variant
- Dim n As Integer, i As Integer, j As Integer, wn As String, k As Integer
- Set sh = ActiveSheet
- fld ThisWorkbook.Path
- Application.ScreenUpdating = False
- Sheet6.Range("a1").CurrentRegion.Offset(1).ClearContents
- For i = 1 To UBound(arr)
- Myname = Dir(arr(i))
- wn = Replace(Myname, ".xls", "")
- If InStr(wn, "结算") Then
- If Myname <> ThisWorkbook.Name Then
- With GetObject(arr(i))
- If .Sheets("表三甲") Is Nothing Then GoTo nn
- crr = .Sheets("表三甲").Range("a7:e" & .Sheets("表三甲").[b65536].End(3).Row).Value
- For j = 1 To UBound(crr)
- If crr(j, 1) <> "" Then
- n = n + 1
- brr(n, 1) = wn: brr(n, 2) = crr(j, 1)
- For k = 3 To 5
- brr(n, k) = crr(j, k)
- Next
- End If
- Next
- .Close False
- End With
- End If
- End If
- nn:
- Next
- Erase arr
- l = 0
- Sheet6.[a2].Resize(n, 5).Value = brr
- Application.ScreenUpdating = True
- End Sub
复制代码 |
|