一看就会，一写就废的案例，这儿有一个。
▎具体需求
小张是某公司员工，这两天遇到一个这样的小问题。
有一个专门放日报表的文件夹，不定时的需要汇总件夹中所有日报的内容。如果一次两次的手动粘贴还好，但是不定时的重复多次粘贴复制汇总，实在让人反感。
这是文件夹
这是日报表的格式，红色框是需提取的内容
这是汇总之后的样子
▎问题分析
这个问题其实是一个很简单的VBA入门问题，几句代码就可搞定。
循环打开→复制固定区域数据→粘贴到汇总表
其实这么基础简单的代码，能拦住很多人。但这恰恰是最常见、最基础的VBA需求。
▎代码详解
Sub 循环打开工作簿()Application.DisplayAlerts = FalseApplication.ScreenUpdating = FalseApplication.AskToUpdateLinks = FalseDim wb As Workbookcol = 2Set hz = Worksheets("汇总结果") '把汇总结果sheet赋值给对象变量hzhz.Cells.clear '清除上次结果myname = Dir(ThisWorkbook.Path & "\" & "*.xls*") 'Dir函数首次获取代码工作簿路径下的文件名Do While myname <> "" 'Do While循环会一直运行，只到myname变量是空值If myname <> ThisWorkbook.Name ThenSet 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 Ifmyname = Dir 'Dir函数再次获取代码工作簿路径下的文件名Loophz.Columns.AutoFit '汇总结果表，列自动适配列宽hz.Select '激活汇总结果表Application.DisplayAlerts = TrueApplication.ScreenUpdating = TrueApplication.AskToUpdateLinks = TrueMsgBox "汇总完成！"End SubSub clear()Set hz = Worksheets("汇总结果")hz.Cells.clearMsgBox "已清除上次结果"End Sub
后台回复：日报表 ，可获取文章附件素材。
评论