2,462
社区成员
发帖
与我相关
我的任务
分享
Sub 汇总()
Application.ScreenUpdating = False '防止屏幕闪烁
Dim wb As Excel.Workbook '定义变量
Sheet1.Rows("2:60000") = "" '清除原数据
f = Dir(ThisWorkbook.Path & "\*.xls*") '生成查找EXCEL的目录,可以适应不同版本
Do While f <> "" '在目录中循环
If f <> ThisWorkbook.Name Then '如果不是打开的工作簿
Set wb = Workbooks.Open(ThisWorkbook.Path & "\" & f) '依次打开目录工作薄
wb.Worksheets(1).UsedRange.Offset(0).Copy ThisWorkbook.Worksheets(1).Cells(Rows.Count, 2).End(xlUp).Offset(1) '拷贝数据
ThisWorkbook.Worksheets(1).Cells(Rows.Count, 1).End(xlUp).Offset(1).Resize(wb.Worksheets(1).UsedRange.Rows.Count, 1) = Split(wb.Name, ".")(0) '文件名称
wb.Close False '关闭打开的工作薄
End If
f = Dir '寻找下一个文件
Loop '结束循环
Application.ScreenUpdating = True '
End Sub