4.1 工作表快速拆分
4.1.1 员工信息表快速拆分
从一张员工信息总表中快速把每个部门的员工信息拆分出来，并且另存为新工作簿。
Sub 拆分工作表()
Dim cnn As New ADODB.Connection
Dim rs As ADODB.Recordset
Dim ws As Worksheet
Dim wb As Workbook
Dim n As Variant, i As Integer, j As Integer
'建立与工作簿的连接
With cnn
.Provider = "microsoft.ace.oledb.12.0"
.ConnectionString = "ExtendedProperties=Excel 12.0; Data Source=" & ThisWorkbook.FullName
.Open
End With
Dim sql As String
sql = "select distinct 部门 from [基本信息$]"
Set rs = New ADODB.Recordset
rs.Open sql, cnn, adOpenKeyset, adLockOptimistic
n = rs.RecordCount
ReDim arr(1 To n) As String
For i = 1 To n
arr(i) = rs.Fields(0).Value
rs.MoveNext
Next i
For i = 1 To n
sql = "select * from [基本信息$] where 部门='" & arr(i) & "'"
Set rs = New ADODB.Recordset
rs.Open sql, cnn, adOpenKeyset, adLockOptimistic
Set wb = Workbooks.Add
Set ws = wb.Worksheets(1)
With ws
For j = 1 To rs.Fields.Count
.Cells(1, j) = rs.Fields(j - 1).Name
Next j
.Range("a2").CopyFromRecordset rs
End With
wb.SaveAs Filename:=ThisWorkbook.Path & "\案例4-1\" & arr(i) & ".xlsx"
wb.Close
Next i
MsgBox "工作簿拆分完毕！"
End Sub4.1.2 如何将上述表按部门拆分成新的工作表
Sub 拆分工作表()
Dim cnn As New ADODB.Connection
Dim rs As ADODB.Recordset
Dim ws As Worksheet
Dim wb As Workbook
Dim n As Variant, i As Integer, j As Integer
'建立与工作簿的连接
With cnn
.Provider = "microsoft.ace.oledb.12.0"
.ConnectionString = "ExtendedProperties=Excel 12.0; Data Source=" & ThisWorkbook.FullName
.Open
End With
Dim sql As String
sql = "select distinct 部门 from [基本信息$]"
Set rs = New ADODB.Recordset
rs.Open sql, cnn, adOpenKeyset, adLockOptimistic
n = rs.RecordCount
ReDim arr(1 To n) As String
For i = 1 To n
arr(i) = rs.Fields(0).Value
rs.MoveNext
On Error Resume Next
Application.DisplayAlerts = False
ThisWorkbook.Worksheets(arr(i)).Delete
Next i
For i = 1 To n
sql = "select * from [基本信息$] where 部门='" & arr(i) & "'"
Set rs = New ADODB.Recordset
rs.Open sql, cnn, adOpenKeyset, adLockOptimistic
Set ws = ThisWorkbook.Worksheets.Add(after:=Sheets(Sheets.Count))
With ws
For j = 1 To rs.Fields.Count
.Cells(1, j) = rs.Fields(j - 1).Name
Next j
.Range("a2").CopyFromRecordset rs
End With
ws.Name = arr(i)
Next i
MsgBox "工作表拆分完毕！"
Application.DisplayAlerts = True
End Sub4.1.3 快速拆分工作表
在分析数据时，经常需要把数据表按照某种类别进行拆分。如下图所示表格，现需要按“成本对象名称”进行拆分。
代码如下：
Sub 按成本对象名称拆分成本表()
Application.DisplayAlerts = False
Dim cnn As New ADODB.Connection
Dim rs As ADODB.Recordset
Dim ws As Worksheet
Dim n As Variant, i As Integer, j As Integer
Dim sql As String
Dim arr() As Variant
'建立与工作簿的连接
With cnn
.Provider = "microsoft.ace.oledb.12.0"
.ConnectionString = "ExtendedProperties=Excel 12.0; Data Source=" & ThisWorkbook.FullName
.Open
End With
sql = "select distinct 成本对象名称 from [数据$]"
Set rs = New ADODB.Recordset
rs.Open sql, cnn, adOpenKeyset, adLockOptimistic
n = rs.RecordCount
ReDim Preserve arr(1 To n)
For i = 1 To n
arr(i) = rs.Fields(0).Value
rs.MoveNext
On Error Resume Next
ThisWorkbook.Worksheets(arr(i)).Delete
Next i
For i = 1 To n
sql = "select * from [数据$] where 成本对象名称= '" & arr(i) & "'"
Set rs = New ADODB.Recordset
rs.Open sql, cnn, adOpenKeyset, adLockOptimistic
Set ws = Worksheets.Add(after:=Worksheets(Worksheets.Count))
With ws
.Name = arr(i)
For j = 1 To rs.Fields.Count
ws.Cells(1, j) = rs.Fields(j - 1).Name
Next j
ws.Range("a2").CopyFromRecordset rs
End With
Next i
cnn.Close: Set cnn = Nothing
rs.Close: Set rs = Nothing
Application.DisplayAlerts = True
End Sub4.2 工作表快速合并
如何把大量的工作表合并到一个工作表中，加入合并的工作表不在一个工作簿，而是多个独立的工作簿，每个工作表列数不一样，但需要把共有的列数据汇总起来，如何处理？
如果基础表格是规范的表单，使用 Power Query 可以快速地合并并建立数据模型、在此基础上进行各种分析。但是，如果基础表不规范（例如，列数不一样，列顺序不一样，表格顶部还有大标题之类的文字），此时使用 VBA+ADO+SQL 就是一种较好的选择。
4.2.1 快速汇总当前工作簿或其他工作簿中的 N 个工作表
这种问题在实际工作中经常会遇到，例如，将当前工作簿的 12 个月的工资表进行汇总、将另外GARLIC
另外一个工作簿里的 12 个月工资表进行汇总（不打开该工作簿），将工作簿里的数百个店铺数据进行汇总等。
对于这样的汇总，可使用连接查询的方法来完成，也就是对每个工作表的 select 语句用 union 进行连接，即可得到这些工作表的汇总数据。语句基本结构如下（注意，要求每个工作表列结构完全相同，也就是列数相同，列顺序相同）。
select * from [表1$] union
select * from [表2$] union
select * from [表3$] union
…
select * from [表n$]如果仅仅是汇总这些工作表中共有的几列数据，可以用具体的字段列表来代替星号（*）。
select 字段1, 字段2, 字段3…字段n from [表1$] union
select 字段1, 字段2, 字段3…字段n from [表2$] union
select 字段1, 字段2, 字段3…字段n from [表3$] union
…
select 字段1, 字段2, 字段3…字段n from [表n$]4.2.2 快速汇总 N 个工作簿，每个工作簿只有一个工作表
如果是要汇总指定文件中的 N 个工作簿，但每个工作簿中仅有一个工作表，并且每个工作表都有相同的名称，那么可以使用循环访问工作簿的方法来查询每个工作簿数据，然后把每个工作簿数据保存在当前工作簿中。
下面的例子是汇总当前工作簿所在下的子文件夹“案例4-4源文件”里的 6 个工作簿，这些工作簿分别保存 6 个分公司的工资数据。
Sub 合并工作簿数据到一个工作表()
Dim cnn As New ADODB.Connection
Dim rs As New ADODB.Recordset
Dim ws As Worksheet
Dim i, x As Integer
Set ws = ThisWorkbook.Worksheets("汇总表")
ws.Cells.Clear
Dim file() As String, FileStr As String, n As Integer, PathStr As String, HeadRows As Byte, namess As String, ActiveWB As Workbook, cell As Range
With Application.FileDialog(msoFileDialogFolderPicker) '创建文件对话框的实例
If .Show Then '如果在对话框中单击了“确定”
PathStr = .SelectedItems(1) '将选定的路径赋予变量
Else
Exit Sub '否则退出程序
End If
End With
On Error Resume Next
FileStr = Dir(PathStr & IIf(Right(PathStr, 1) = "\", "", "\") & "*.xl*") '获取路径下第一个文件名
While Len(FileStr) > 0 '只要文件名长度大于就循环下去
n = n + 1 '累加变量，该变量等于文件个数
ReDim Preserve file(1 To n) '重新指定数组变量的储存空间
file(n) = PathStr & IIf(Right(PathStr, 1) = "\", "", "\") & FileStr '将路径与文件名逐个写入数组
FileStr = Dir()
Wend
If n = 0 Then MsgBox "没发现 excel 文件": Exit Sub '如果没有文件则退出程序
For i = 1 To n
x = ws.Cells(Rows.Count, 1).End(xlUp).Row + 1
With cnn
.Provider = "microsoft.ace.oledb.12.0"
.ConnectionString = "extendedproperties=excel 12.0;data source=" & file(i)
.Open
End With
Sql = "select * from [工资表$]"
rs.Open Sql, cnn, adOpenKeyset, adLockOptimistic
For j = 0 To rs.Fields.Count - 1
ws.Cells(1, j + 1) = rs.Fields(j).Name
Next j
ws.Range("a" & x).CopyFromRecordset rs
rs.Close
cnn.Close
Next i
x = ws.Cells(Rows.Count, 1).End(xlUp).Row
If x >= 2 Then
MsgBox "共计成功合并" & x - 1 & "条数据!"
End If
End Sub如果不是将工作簿数据汇总到当前工作簿的一个工作表中，而是分别保存在当前工作簿不同的工作表中，工作表名称就是工作簿名称，程序如下：
Sub 合并工作簿数据_分工作表()
Application.DisplayAlerts = False
Dim cnn As New ADODB.Connection
Dim rs As New ADODB.Recordset
Dim ws As Worksheet
Dim i, j As Integer
Dim file() As String, FileStr As String, n As Integer, PathStr As String
Dim arr() As String
With Application.FileDialog(msoFileDialogFolderPicker) '创建文件对话框的实例
If .Show Then '如果在对话框中单击了“确定”
PathStr = .SelectedItems(1) '将选定的路径赋予变量
Else
Exit Sub '否则退出程序
End If
End With
On Error Resume Next
FileStr = Dir(PathStr & IIf(Right(PathStr, 1) = "\", "", "\") & "*.xl*") '获取路径下第一个文件名
While Len(FileStr) > 0 '只要文件名长度大于就循环下去
n = n + 1 '累加变量，该变量等于文件个数
ReDim Preserve file(1 To n)
'重新指定数组变量的储存空间
file(n) = PathStr & IIf(Right(PathStr, 1) = "\", "", "\") & FileStr '将路径与文件名逐个写入数组
FileStr = Dir()
Wend
For i = 1 To UBound(file)
ReDim Preserve arr(1 To UBound(file))
Set fso = CreateObject("scripting.filesystemobject")
arr(i) = fso.getbasename(file(i)) 'GetBaseName 方法 描述返回一个包含路径中最后部件的基本名字（去掉任何文件扩展名）的字符串。
Next i
If n = 0 Then MsgBox "没发现 excel 文件": Exit Sub '如果没有文件则退出程序
On Error Resume Next
For i = 1 To UBound(file)
ThisWorkbook.Worksheets(arr(i)).Delete
Next i
For i = 1 To UBound(file)
Set ws = Worksheets.Add(after:=Worksheets(Worksheets.Count))
ws.Name = arr(i)
With cnn
.Provider = "microsoft.ace.oledb.12.0"
.ConnectionString = "extendedproperties=excel 12.0;data source=" & file(i)
.Open
End With
Sql = "select * from [工资表$]"
rs.Open Sql, cnn, adOpenKeyset, adLockOptimistic
For j = 0 To rs.Fields.Count - 1
ws.Cells(1, j + 1) = rs.Fields(j).Name
Next j
ws.Range("a2").CopyFromRecordset rs
rs.Close
cnn.Close
Next i
Application.DisplayAlerts = True
End Sub4.2.3 快速汇总 N 个工作簿，每个工作簿里有 M 个工作表
如果要汇总的每个工作簿不只包含一个工作表，而是有 M 个工作表，要把这些工作表（N*M）个工作表汇总起来，此时要求每个工作簿的每个工作表列结构必须相同，也就是列数相同，列顺序相同。这种汇总的思路是先把每个工作簿的 M 个工作表进行汇总，保存到当前工作簿的新工作表中，然后再将代表每个工作簿的每个工作表的汇总数据集归纳到一张表上。
下面案例中，文件夹下有 6 个工作簿，每个工作簿中有 12 个工作表，分别存储该公司 1 月-12 月份员工工资数据，现要将这 6 个工作簿的数据合并到新工作簿的 6 个工作表中，最后一步再将 6 个工作表中的数据合并到“汇总表”工作表中。
代码如下：
Sub 合并汇总多个工作簿的多个工作表()
Application.DisplayAlerts = False
Dim cnn As ADODB.Connection
Dim rs As ADODB.Recordset
Dim ws As Worksheet
Dim i As Integer, j As Integer
Dim SQL As String
Dim file() As String, FileStr As String, n As Integer, PathStr As String
Dim arr() As String
With Application.FileDialog(msoFileDialogFolderPicker) '创建文件对话框的实例
If .Show Then '如果在对话框中单击了“确定”
PathStr = .SelectedItems(1) '将选定的路径赋予变量
Else
Exit Sub '否则退出程序
End If
End With
On Error Resume Next
FileStr = Dir(PathStr & IIf(Right(PathStr, 1) = "\", "", "\") & "*.xl*") '获取路径下第一个文件名
While Len(FileStr) > 0 '只要文件名长度大于就循环下去
n = n + 1 '累加变量，该变量等于文件个数
ReDim Preserve file(1 To n)
'重新指定数组变量的储存空间
file(n) = PathStr & IIf(Right(PathStr, 1) = "\", "", "\") & FileStr '将路径与文件名逐个写入数组
FileStr = Dir()
Wend
For i = 1 To UBound(file)
ReDim Preserve arr(1 To UBound(file))
Set fso = CreateObject("scripting.filesystemobject")
arr(i) = fso.getbasename(file(i)) 'GetBaseName 方法 描述返回一个包含路径中最后部件的基本名字（去掉任何文件扩展名）的字符串。
Next i
If n = 0 Then MsgBox "没发现 excel 文件": Exit Sub '如果没有文件则退出程序
On Error Resume Next
For i = 1 To UBound(file)
ThisWorkbook.Worksheets(arr(i)).Delete
Next i
'依次访问每个工作簿，查询数据
For i = 1 To UBound(file)
'建立与每个工作簿的连接
Set cnn = New ADODB.Connection
With cnn
.Provider = "microsoft.ace.oledb.12.0"
.ConnectionString = "ExtendedProperties=Excel 12.0; " _
& "Data Source=" & file(i)
.Open
End With
'查询每个工作簿数据
SQL = "select '" & arr(i) & "' as 分公司,'1月' as 月份,* from [1月$] union " _
& "select '" & arr(i) & "' as 分公司,'2月' as 月份,* from [2月$] union " _
& "select '" & arr(i) & "' as 分公司,'3月' as 月份,* from [3月$] union " _
& "select '" & arr(i) & "' as 分公司,'4月' as 月份,* from [4月$] union " _
& "select '" & arr(i) & "' as 分公司,'5月' as 月份,* from [5月$] union " _
& "select '" & arr(i) & "' as 分公司,'6月' as 月份,* from [6月$] union " _
& "select '" & arr(i) & "' as 分公司,'7月' as 月份,* from [7月$] union " _
& "select '" & arr(i) & "' as 分公司,'8月' as 月份,* from [8月$] union " _
& "select '" & arr(i) & "' as 分公司,'9月' as 月份,* from [9月$] union " _
& "select '" & arr(i) & "' as 分公司,'10月' as 月份,* from [10月$] union " _
& "select '" & arr(i) & "' as 分公司,'11月' as 月份,* from [11月$] union " _
& "select '" & arr(i) & "' as 分公司,'12月' as 月份,* from [12月$]"
Set rs = New ADODB.Recordset
rs.Open SQL, cnn, adOpenKeyset, adLockOptimistic
'创建工作表
Set ws = Worksheets.Add(after:=Worksheets(Worksheets.Count))
ws.Name = arr(i)
'往每个新工作表中复制数据
For j = 1 To rs.Fields.Count
ws.Cells(1, j) = rs.Fields(j - 1).Name
Next j
ws.Range("A2").CopyFromRecordset rs
'关闭该工作簿的查询和连接
rs.Close
cnn.Close
Next i
'-----再将当前工作簿中的几个分公司数据汇总到一个工作表-----
Set ws = ThisWorkbook.Worksheets("汇总表")
'建立与当前工作簿的连接
Set cnn = New ADODB.Connection
With cnn
.Provider = "microsoft.ace.oledb.12.0"
.ConnectionString = "ExtendedProperties=Excel 12.0; " _
& "Data Source=" & ThisWorkbook.FullName
.Open
End With
'编写 SQL 语句
SQL = ""
For i = 1 To UBound(arr)
SQL = SQL & "select * from [" & arr(i) & "$] union "
Next i
SQL = SQL & "select * from [" & arr(UBound(arr)) & "$]"
'进行查询
Set rs = New ADODB.Recordset
rs.Open SQL, cnn, adOpenKeyset, adLockOptimistic
'复制标题
For j = 1 To rs.Fields.Count
ws.Cells(1, j) = rs.Fields(j - 1).Name
Next j
'复制数据
ws.Range("A2").CopyFromRecordset rs
'关闭查询和连接
rs.Close
cnn.Close
Set rs = Nothing
Set cnn = Nothing
Application.DisplayAlerts = True
MsgBox "汇总完毕！", vbInformation, "汇总工作簿"
End Sub