上班以后大部分时间用不到功能特别强大的软件，但office却是形影不离。理工科或者会计等工作需要整合大量的数据表格，如果全靠复制粘贴会浪费大量时间，也非常辛苦。为了提高效率，我做了个小程序。如下图：
把需要收集数据的Excel文件（格式相同）放置在一个文件夹里，点击”数据整合“按钮，即可输出一个整合后的表格文件。代码如下：
数据整合：
Private Sub 数据整合_Click()
Application.ScreenUpdating = False
On Error GoTo 0
Dim nYs%, nRow%, cTxt$, nBl#, Arr(), nCount%
Dim r%, m%
Dim ws As Worksheet
Dim wb As Workbook
Dim mypath$, myname$
Dim brr()
Dim f As Object
Dim n%
Worksheets("数据库表").Range("2:65536").ClearContents
mypath = ThisWorkbook.Path & "\Excel文件集\"
myname = Dir(mypath & "*.xlsx")
ReDim Preserve brr(1 To 12, 1 To m)
brr(1, m) = Format(.Range("C2"), "'000000000000")
brr(2, m) = .Range("C3")
brr(3, m) = .Range("C5")
brr(4, m) = .Range("I3")
brr(5, m) = .Range("I4")
brr(6, m) = .Range("I5")
brr(7, m) = .Range("C8")
brr(8, m) = .Range("C4")
brr(9, m) = .Range("C64")
brr(10, m) = Format(.Range("C66"), "yyyy年mm月dd日")
brr(11, m) = Format(.Range("I66"), "yyyy年mm月dd日")
brr(12, m) = .Range("C65")
End With
wb.Close
myname = Dir()
Loop
With Worksheets("数据库表")
r = .Cells(.Rows.Count, 1).End(xlUp).Row
.Range("a" & r + 1).Resize(UBound(brr, 2), UBound(brr)) = Application.Transpose(brr)
End With
Next
MsgBox "数据收集完毕！！！", 0 + 48 + 256 + 0, "提示："
Sheets("数据库表").Select
Sheets("数据库表").Cells.Select
Selection.Copy
Sheets("数据库表").Copy
With ActiveWorkbook
.SaveAs Filename:=ThisWorkbook.Path & "\数据收集Excel\" & "数据整合表" & Year(Now()) & "年" & Month(Now()) & "月" & Day(Now()) & "日" & Hour(Now()) & "时" & Minute(Now()) & "分" & Second(Now()) & "秒" & ".xlsx"
.Close
End With
MsgBox "已生成“" & ThisWorkbook.Path & "\数据收集Excel\" & "数据整合表" & Year(Now()) & "年" & Month(Now()) & "月" & Day(Now()) & "日" & Hour(Now()) & "时" & Minute(Now()) & "分" & Second(Now()) & "秒" & ".xlsx" & "”！", 0 + 48 + 256 + 0, "提示："
Application.ScreenUpdating = True
End Sub
经测算得知，每个Excel文件耗时约0.6s。文件较少时，点击“数据整合”按钮后程序很快就能够结束运行。但是当文件增加到20个以上，程序处理时间就达到了让人厌烦的程度，如果整合1000个Excel文件就需要花费10分钟，你也许会认为系统卡死了，那是想哭的心都有了。为了解决这个等待问题，我给程序添加了个进度条，这样就很直观的显示出了数据处理的进程，我们可以先做别的事情，等软件运行到100%再管他好了。
进度条：
For Each f In CreateObject("scripting.FileSystemObject").GetFolder(mypath).Files
If f.Name Like "*.xlsx" Then n = n + 1 '查看文件夹里.xlsx文件的数量
Next
nYs = Int(Rnd * 6 + 1) '随机一个颜色号
For m = 0 To n
'm = 0
Do While myname <> ""
Set wb = GetObject(mypath & myname)
With wb.Worksheets(1)
m = m + 1
Me.Label1.ForeColor = Choose(nYs, 30720, 16711935, 16711680, 255, 32255, 16762880) '底层字体颜色
'===========================================================进度条开始
nBl = m / n '进度百分比
With Me
Select Case nYs '进度条颜色
Case 1
'绿色
.Label2.BackColor = RGB(200 * (1 - nBl), 233 - 113 * nBl, 200 * (1 - nBl))
Case 2
'粉
.Label2.BackColor = RGB(245 - 80 * nBl, 210 * (1 - nBl), 245 - 80 * nBl)
Case 3
'蓝色
.Label2.BackColor = RGB(210 * (1 - nBl), 225 - 170 * nBl, 245 - 125 * nBl)
Case 4
'红色
.Label2.BackColor = RGB(255, 200 * (1 - nBl), 200 * (1 - nBl))
Case 5
'棕色
.Label2.BackColor = RGB(250, 230 - 95 * nBl, 200 * (1 - nBl))
Case 6
'青色
.Label2.BackColor = RGB(220 * (1 - nBl), 255 - 135 * nBl, 255 - 135 * nBl)
End Select
.Label2.Width = 370 * nBl '进度条长度(370是总长度，设计时有变请修改）
.Label1.Caption = String(37, " ") & Format(nBl, "0%") '底层文字，前面的空格个数37根据实际修改
.Label3.Caption = .Label1.Caption '顶层文字
.Label3.Width = .Label2.Width '限制顶层文字显示宽度
End With
'For j = 1 To 20 '延时，测试用，让进度条慢一点
'next
DoEvents '必须，否则进度条不显示过程
程序还有很多不足，最急需解决的还是速度不够快的问题，如果大家有什么好的点子，还请不吝赐教！
参考资料：
- 中文版Excel 2016高级VBA编程宝典（第8版）.[美]Michael Alexander
- http://www.excelhome.net/