|
Sub 合并()
Application.ScreenUpdating = False
Dim ar As Variant
Dim br()
ReDim br(1 To 10000, 1 To 3)
f = Dir(ThisWorkbook.Path & "\*.xls*")
Do While f <> ""
If f <> ThisWorkbook.Name Then
Set wb = Workbooks.Open(ThisWorkbook.Path & "\" & f, 0)
ar = wb.Worksheets(1).[a1].CurrentRegion
wb.Close False
For i = 5 To UBound(ar)
If Trim(ar(i, 1)) <> "" Then
For j = 2 To UBound(ar, 2)
If Trim(ar(i, j)) <> "" Then
n = n + 1
br(n, 1) = ar(2, 3)
br(n, 2) = ar(i, j)
br(n, 3) = ar(i, 1)
End If
Next j
End If
Next i
End If
f = Dir
Loop
With Sheet1
.[a1].CurrentRegion.Offset(1) = Empty
.[a2].Resize(n, 3) = br
End With
Application.ScreenUpdating = True
MsgBox "ok"
End Sub
|
|