- Sub hz()
- Application.ScreenUpdating = False
- Dim brr(), arr, i&, s&
- Dim fso As Object
- Set fso = CreateObject("scripting.filesystemobject")
- Set f1 = fso.getfolder(ThisWorkbook.Path)
- s = 1
- For Each aa In f1.subfolders
- If aa.Name Like "*月" Then
- For Each bb In aa.Files
- With GetObject(bb.Path)
- arr = .Sheets(1).Range("a33:R" & .Sheets(1).[a33].End(xlDown).Row)
- For i = 1 To UBound(arr)
- ReDim Preserve brr(1 To 9, 1 To s)
- If arr(i, 18) <> "" Then
- brr(1, s) = arr(i, 1): brr(2, s) = arr(i, 2): brr(3, s) = arr(i, 3): brr(4, s) = arr(i, 4): brr(5, s) = arr(i, 6): brr(6, s) = arr(i, 7): brr(7, s) = arr(i, 8): brr(8, s) = arr(i, 10): brr(9, s) = arr(i, 18)
- s = s + 1
- End If
- Next
- .Close False
- Erase arr
- End With
- Next
- End If
- Next
- Range("A4:I200").ClearContents
- [a4].Resize(UBound(brr, 2), 9) = Application.Transpose(brr)
- Application.ScreenUpdating = True
- End Sub
复制代码 |