|
|
Sub 获取文件夹列表()
Application.ScreenUpdating = False
Dim arr()
Dim fs As Object
Set fs = CreateObject("Scripting.FileSystemObject")
Set f = fs.getfolder(ThisWorkbook.Path)
For Each fd In f.subfolders
n = n + 1
ReDim Preserve arr(1 To n)
arr(n) = fd.Name
Next
Set f = Nothing
Set fs = Nothing
Dim d As Object
Set d = CreateObject("scripting.dictionary")
Set dc = CreateObject("scripting.dictionary")
With Sheets("汇总表")
r = .Cells(Rows.Count, 1).End(xlUp).Row
y = .Cells(2, Columns.Count).End(xlToLeft).Column
If r > 2 Then .Range(.Cells(3, 1), .Cells(r, y)) = Empty
ar = .Range(.Cells(2, 1), .Cells(2000, y))
For j = 4 To y
If Trim(ar(1, j)) <> "" Then
d(Trim(ar(1, j))) = j
End If
Next j
k = 1
For s = 1 To n
f = Dir(ThisWorkbook.Path & "\" & arr(s) & "\*.xls*")
Do While f <> ""
Set wb = Workbooks.Open(ThisWorkbook.Path & "\" & arr(s) & "\" & f, 0)
With wb.Worksheets(1)
br = .UsedRange
Set rn = .Rows(3).Find(arr(s), , , , , , 1)
h = rn.Column
End With
wb.Close False
lh = d(Trim(br(3, h)))
For i = 4 To UBound(br)
If Trim(br(i, 1)) <> "" Then
t = dc(Trim(br(i, 1)))
If t = "" Then
k = k + 1
dc(Trim(br(i, 1))) = k
t = k
ar(k, 1) = br(i, 1)
ar(k, 2) = br(2, 2)
ar(k, 3) = br(i, 2)
End If
If lh <> "" Then
ar(t, lh) = br(i, h)
End If
End If
Next i
f = Dir
Loop
Set f = Nothing
Next s
.Cells(2, 1).Resize(k, UBound(ar, 2)) = ar
End With
Application.ScreenUpdating = True
MsgBox "ok!"
End Sub
|
|
沪公网安备 31011702000001号 沪ICP备11019229号-2
发表于 2023-4-14 10:30
楼主