"增加二句。

"同一資料夾下再建一個彙總工作簿，把下面程式碼放入彙總工作簿中。

Sub ABCD()

Dim lj As String

Dim dirname As String

Dim nm As String

lj = ActiveWorkbook.Path

nm = ActiveWorkbook.Name

dirname = Dir(lj & "\*.xls")

Cells.Clear

Do While dirname <> ""

If dirname <> nm Then

Workbooks.Open Filename:=lj & "\" & dirname

Application.Visible = False

"上面一句增加

Workbooks(nm).Activate

Workbooks(dirname).Sheets(1).Range("A4:J15").Copy _

Sheets(1).Range("a65536").End(xlUp).Offset(1, 0)

Workbooks(dirname).Close False

End If

dirname = Dir

Loop

"下面一句增加

Application.Visible = True

End Sub