|
Sub Macro1()
Dim MyPath$, MyName$, sh As Worksheet, sht As Worksheet
Application.ScreenUpdating = False
Set sh = ActiveSheet
MyPath = ThisWorkbook.Path & "\"
MyName = Dir(MyPath & "*.xls")
[a1].CurrentRegion.Offset(2).Clear
Do While MyName <> ""
If MyName <> ThisWorkbook.Name Then
With GetObject(MyPath & MyName)
For Each sht In .Sheets
If sht.[a1].CurrentRegion.Rows.Count > 2 Then
lr = sh.[a1].CurrentRegion.Rows.Count + 1
r = sht.[a1].CurrentRegion.Rows.Count - 2
sh.Cells(lr, 1).Resize(r) = MyName
sh.Cells(lr, 2).Resize(r) = sht.Name
sht.[a1].CurrentRegion.Offset(2).Copy sh.Cells(lr, 3)
End If
Next
.Close False
End With
End If
MyName = Dir
Loop
Application.ScreenUpdating = True
MsgBox "ok"
End Sub
|
|