|
Sub 合并()
Application.ScreenUpdating = False
Dim fs As Object
Dim ar()
ReDim ar(1 To 1000, 1 To 1)
Set sh = ThisWorkbook.Worksheets(1)
sh.UsedRange.Clear
Set fs = CreateObject("Scripting.FileSystemObject")
Set f = fs.getfolder(ThisWorkbook.Path)
For Each fd In f.subfolders
n = n + 1
ar(n, 1) = fd.Name
Next
Set f = Nothing
Set fs = Nothing
For i = 1 To n
f = Dir(ThisWorkbook.Path & "\" & ar(i, 1) & "\*.csv")
Do While f <> ""
Set wb = Workbooks.Open(ThisWorkbook.Path & "\" & ar(i, 1) & "\" & f)
y = y + 1
With wb.Worksheets(1)
r = .Cells(Rows.Count, 2).End(xlUp).Row
sh.Cells(1, y) = ar(i, 1)
.Range("b2:b" & r).Copy sh.Cells(2, y)
End With
wb.Close False
f = Dir
Loop
Next i
Application.ScreenUpdating = True
MsgBox "ok!"
End Sub
|
|