【原】ExcelVBA批量提取日报表

▎具体需求

小张是某公司员工，这两天遇到一个这样的小问题。

有一个专门放日报表的文件夹，不定时的需要汇总件夹中所有日报的内容。如果一次两次的手动粘贴还好，但是不定时的重复多次粘贴复制汇总，实在让人反感。

这是文件夹

这是日报表的格式，红色框是需提取的内容

这是汇总之后的样子

▎问题分析

这个问题其实是一个很简单的VBA入门问题，几句代码就可搞定。

循环打开→复制固定区域数据→粘贴到汇总表

其实这么基础简单的代码，能拦住很多人。但这恰恰是最常见、最基础的VBA需求。

▎代码详解

• 
  

• 
  

• 
  

• 
  

• 
  

• 
  

• 
  

• 
  

• 
  

• 
  

• 
  

• 
  

• 
  

• 
  

• 
  

• 
  

• 
  

• 
  

• 
  

• 
  

• 
  

• 
  

• 
  

• 
  

• 
  

• 
  

• 
  

• 
  

• 
  

• 
  

• 
  

• 
  

Sub 循环打开工作簿() Application.DisplayAlerts = False Application.ScreenUpdating = False Application.AskToUpdateLinks = False Dim wb As Workbook col = 2 Set hz = Worksheets("汇总结果") '把汇总结果sheet赋值给对象变量hz hz.Cells.clear '清除上次结果 myname = Dir(ThisWorkbook.Path & "\" & "*.xls*") 'Dir函数首次获取代码工作簿路径下的文件名 Do While myname <> "" 'Do While循环会一直运行，只到myname变量是空值 If myname <> ThisWorkbook.Name Then Set wb = Workbooks.Open(ThisWorkbook.Path & "\" & myname) wb.ActiveSheet.Range("a6:a27").Copy hz.Range("a2") '复制标题列 wb.ActiveSheet.Range("b6:b27").Copy hz.Cells(2, col) '复制数据列 hz.Cells(1, col) = Replace(Replace(myname, ".xlsx", ""), ".xls", "") '替换后缀为空，获取文件名 col = col + 1 '列号+1，为了下一次写入文件名 wb.Close False '关闭打开的日报表工作簿，并且不保存 End If myname = Dir 'Dir函数再次获取代码工作簿路径下的文件名 Loop hz.Columns.AutoFit '汇总结果表，列自动适配列宽 hz.Select '激活汇总结果表 Application.DisplayAlerts = True Application.ScreenUpdating = True Application.AskToUpdateLinks = True MsgBox "汇总完成！"End SubSub clear() Set hz = Worksheets("汇总结果") hz.Cells.clear MsgBox "已清除上次结果"End Sub