這個試下Sub UnionWorksheets() Application.ScreenUpdating = False 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 Workbooks(nm).Activate "複製新開啟工作簿的第一個工作表的已用區域到當前工作表 Workbooks(dirname).Sheets(1).UsedRange.Copy _ Range("A65536").End(xlUp).Offset(1, 0) Workbooks(dirname).Close False End If dirname = Dir LoopEnd Sub