Sub HzwWb()
Dim bt As Range, r As Long, c As Long
r = 1 '表头行数
c = 4 '表头列数
Range(Cells(r + 1, "a"), Cells(1024576, c)).ClearContents '清除汇总表中原数据
Application.ScreenUpdating = False
Dim filename As String, wb As Workbook, erow As Long, fn As String, arr As Variant
filename = Dir(ThisWorkbook.Path & "\*.xls")
Do While filename <> ""
If filename <> ThisWorkbook.Name Then '判断文件是否是本工作簿
erow = Range("a1").CurrentRegion.Rows.Count + 1 '取得汇总表中第一条空行行号
fn = ThisWorkbook.Path & "\" & filename
Set wb = GetObject(fn) '将fn代表的工作簿变量赋给wb
Set sht = wb.Worksheets(1) '汇总的是每个工作簿中的第一张工作表
'将数据表中的记录保存在arr变量中
arr = sht.Range(sht.Cells(r + 1, "A"), sht.Cells(1024576, "B").End(xlUp).Offset(0, c - 1))
'将arr数据写入汇总表
Cells(erow, "A").Resize(UBound(arr, 1), UBound(arr, 2)) = arr
wb.Close False
End If
filename = Dir '用dir函数取得其他文件名,并赋给变量
Loop
Application.ScreenUpdating = True
End Sub