多工作簿多表查询汇总的通用解决方案

microyip · 发表于 2016-11-9 08:22

      长期以来，论坛内不断出现求多个工作簿、多个工作表进行汇总的求助贴，开始时，抱着能帮多少就多少的心态去尽自己能力去进行帮助，但有时一天内出现几个汇总求助，只是汇总数据的格式不一样，标题字段不一样而已，作为求助者稍微学习一下VBA基础知识，然后照搬照挪代码，就基本可以自己完成的事，却不厌其烦的出现在求助队列里。
      本着授之以鱼不如授之以渔的思想，做了一个自己的汇总代码模版，希望能给有汇总需求提供到一定帮助，给初学者一个指引编写代码的学习机会。
      代码不一定是非常优秀，希望各位大神级的朋友不要贱笑，也敬请多多指教，多多指正。
前提，所有操作中的表或工作簿中，必须包含所有查询所需的字段标题，但不一定要按同样顺序
附件中，每行代码都注释了作用，希望各位初学者学习一些语句的应用。包含了对工作簿汇总的数组方案、SQL方案；对工作表汇总的数组方案、SQL方案。

microyip · 发表于 2016-11-9 08:23

本帖最后由 microyip 于 2016-11-9 08:25 编辑

数组解决方案中涉及调整规范数据格式的代码

Function 规范数据格式(vReadData As Variant, vTitle As Variant) As Variant
'将数据规范为一定格式，本例中的格式是：姓名、年龄、籍贯、区域
Dim oDic As Object '定义字典对象变量
Dim nRow As Double, nCol As Integer, nNewCol As Integer
Dim vData As Variant '定义数据规范的数组
Set oDic = CreateObject("Scripting.Dictionary") '定义oDic为字典变量
'注意：标题的数量要与vReadData数组对应
For nRow = LBound(vTitle) To UBound(vTitle) '从数组的最低标号到最高标号循环
oDic(vTitle(nRow)) = nRow + 1 '以标题为关键字的字典，赋值对应于标题数组的标号
Next
vData = vReadData '令vData与vReadData具有同样容量的数组
For nCol = 1 To UBound(vReadData, 2) '列号从1到vReadData第二维最高标号，即最右的列号
nNewCol = oDic(vReadData(1, nCol)) '从vReadData标题行的标题获取数据规范的所在列
For nRow = 2 To UBound(vReadData) '列号从2到vReadData第一维最高标号，即最下的行号
vData(nRow, nNewCol) = vReadData(nRow, nCol) '把vReadData赋值到数据规范的数组
Next
Next
规范数据格式 = vData '返回规范数据的数组
End Function

复制代码

microyip · 发表于 2016-11-9 08:27

使用数组访问多个工作簿进行汇总的解决方案

Sub 数组查找工作簿汇总()
Dim vReadData As Variant '定义读取工作簿中表的数据的数组变量
Dim vData As Variant '定义读取工作簿中表的规范格式数据的数组变量
Dim wWB As Workbook '定义工作簿变量
Dim sPath As String '定义文件夹变量
Dim sFile As String '定义文件名变量
Dim nRow As Double '定义行数变量
Dim nCol As Integer '定义列数变量
Dim bAdd As Boolean '定义是否需要作为新记录添加的逻辑变量
Dim vFill As Variant '定义将要作为查询结果的数组变量
Dim nFill As Double '定义查询结果数组的行数的变量
Dim sName As String, sPlace As String, sArea As String, vAge As Variant
Dim vTitle As Variant '定义标题变量
Application.ScreenUpdating = False '禁止数据更新，避免因数据更新时引起闪屏，提高运行速度
vTitle = Split("姓名|年龄|籍贯|区域", "|") '将所有标题用|隔开的字符串根据|分离成数组
sName = Trim([A2]) '获取查询姓名的条件
sPlace = Trim([A6]) '获取查询籍贯的条件
sArea = Trim([A8]) '获取查询区域的条件
vAge = [A4:B4].Value '获取查询年龄的条件
ReDim vFill(1 To 4, 1 To 1) '定义一个4列1行的数组
'注意：正常填到表格内的数组是按(行，列)来定义的，因为考虑到行数将不断增加，而且数组只能是最后一个维度上进行变化，所以先将行定义在后面
Set wWB = ThisWorkbook '设置本工作簿的变量
sPath = wWB.Path & "" '获取本工作簿所在文件夹
sFile = Dir(sPath & "*.xls*") '查找sPath文件夹内的与xls有关后缀名的文件
Do While sFile <> "" '如果查找不到相关文件将会返回空字符串，找到的话，将返回文件名的全名
If sFile <> ThisWorkbook.Name Then '如果找到的文件名不等于本工作簿的文件名
With Workbooks.Open(sPath & sFile) '打开工作簿sFile
vReadData = .Sheets(1).UsedRange.Value '将第一个表的所有已用单元格的数值赋值给数组
.Close False '关闭工作簿sFile
End With
vData = 规范数据格式(vReadData, vTitle) '如果所有工作簿内数据格式一致，可以跳过本步，上一步的赋值给vReadData的时候直接赋值给vData即可
For nRow = 2 To UBound(vData) 'vData中，第1行是标题，故从2行开始读取数据
bAdd = True '初始化变量为真
If sName <> "" Then bAdd = bAdd And (vData(nRow, 1) Like "*" & sName & "*")
'假如存在姓名条件，且姓名类似条件形式，为真，并跟bAdd进行与运算，例如：条件是”张“，那么”张三“就类似”*张*“
If vAge(1, 2) <> "" Then bAdd = bAdd And Application.Evaluate(vData(nRow, 2) & IIf(vAge(1, 1) = "", "=", vAge(1, 1)) & vAge(1, 2))
'Evaluate是计算一个字符串形式的式子的值
'IIf(vAge(1, 1) = "", "=", vAge(1, 1)) ,如果年龄的比较符号vAge(1, 1)没有被选择，默认使用等于号
'整个语句就是当条件中有年龄条件数值，对比数据中年龄vData(nRow, 2)是否符合条件
If sPlace <> "" Then bAdd = bAdd And (vData(nRow, 1) = sPlace)
'假如存在籍贯条件，且籍贯与条件相同，为真，并跟bAdd进行与运算
If sArea <> "" Then bAdd = bAdd And (vData(nRow, 1) = sArea)
'假如存在区域条件，且区域与条件相同，为真，并跟bAdd进行与运算
If bAdd Then '假如条件符合判断逻辑变量bAdd为真时
nFill = nFill + 1 '为查询数据数组的行数增加一行
ReDim Preserve vFill(1 To 4, 1 To nFill) '为增加一行的查询数据数组重定义
For nCol = 1 To 4
vFill(nCol, nFill) = vData(nRow, nCol) '复制符合条件的一行数据到查询数据数组最后一行上
Next
End If
Next
End If
sFile = Dir '查询一个符合条件的文件
Loop
ThisWorkbook.Activate '本工作簿激活为使用状态
With Sheets("汇总") '对”汇总“表进行操作
.[F:I].ClearContents '清空汇总表内的F:I列数据
.[F1:I1] = Split("姓名,年龄,籍贯,区域", ",") '通过以逗号为拆分词来拆分字符串所得数组赋值给F1:I1单元格作为标题
If nFill > 0 Then '假如查询数据数组的记录行数大于0，即表示有数据
.[F2].Resize(nFill, 4) = Application.WorksheetFunction.Transpose(vFill)
'因为前面定义vFill时按（列，行）定义的，需要通过系统的转置函数Transpose转置为（行，列）数组
'赋值给由F2开始变形为nFill行，4列的单元格区域
End If
End With '结束对”汇总“表进行操作
Application.ScreenUpdating = True
End Sub

复制代码

microyip · 发表于 2016-11-9 08:28

使用SQL语句处理多文件汇总的解决方案

Sub SQL查找工作簿汇总()
Dim oRead_Excel_Conn As Object '定义数据集对象变量
Dim sExcel_Select As String '定义EXCEL读取数据SQL语句变量
Dim sRead_File_Conn As String '定义读文件的SQL语句连接变量
Dim sWhere As String 'SQL语句的条件部分变量
Dim wWB As Workbook '定义工作簿变量
Dim sPath As String '定义文件夹变量
Dim sFile As String '定义文件名变量
Dim sName As String, sPlace As String, sArea As String, vAge As Variant
Dim sTitle As Variant '定义SQL查找的标题变量
Dim vTitle As Variant '定义标题变量
Application.ScreenUpdating = False '禁止数据更新，避免因数据更新时引起闪屏，提高运行速度
sTitle = "姓名,年龄,籍贯,区域"
sName = Trim([A2]) '获取查询姓名的条件
sPlace = Trim([A6]) '获取查询籍贯的条件
sArea = Trim([A8]) '获取查询区域的条件
vAge = [A4:B4].Value '获取查询年龄的条件
sWhere = "Where True" '初始SQL的条件语句
If sName <> "" Then sWhere = sWhere & " And [姓名] Like '%" & sName & "%'"
'假如存在姓名条件，定义姓名类似条件给sWhere
If vAge(1, 2) <> "" Then sWhere = sWhere & " And [年龄]" & IIf(vAge(1, 1) = "", "=", vAge(1, 1)) & vAge(1, 2)
'IIf(vAge(1, 1) = "", "=", vAge(1, 1)) ,如果年龄的比较符号vAge(1, 1)没有被选择，默认使用等于号
'假如存在年龄条件，定义年龄对应关系条件给sWhere
If sPlace <> "" Then sWhere = sWhere & " And [籍贯]='" & sPlace & "'"
'假如存在籍贯条件，定义籍贯相等条件给sWhere
If sArea <> "" Then sWhere = sWhere & " And [区域]='" & sArea & "'"
'假如存在区域条件，且区域相等条件给sWhere
Set oRead_Excel_Conn = CreateObject("Adodb.Connection") '建立读EXCEL数据SQL数据集
If Val(Application.Version) < 12 Then '获取Excel的版本号，低于12为Excel2003版及以下，否则为Excel2007版及以上
oRead_Excel_Conn.Open "Provider=Microsoft.Jet.Oledb.4.0;Extended Properties=Excel 8.0;Data Source=" & ThisWorkbook.FullName '建立数据库连接，Excel2003版及以下
Else
oRead_Excel_Conn.Open "Provider=Microsoft.ACE.OLEDB.12.0;Extended Properties=Excel 12.0;Data Source=" & ThisWorkbook.FullName '建立数据库连接，Excel2007版及以上
End If
Set wWB = ThisWorkbook '设置本工作簿的变量
sPath = wWB.Path & "" '获取本工作簿所在文件夹
sFile = Dir(sPath & "*.xls*") '查找sPath文件夹内的与xls有关后缀名的文件
Do While sFile <> "" '如果查找不到相关文件将会返回空字符串，找到的话，将返回文件名的全名
If sFile <> ThisWorkbook.Name Then '如果找到的文件名不等于本工作簿的文件名
If LCase(Left(sFile, 3)) = "xls" Then '如果文件名右边三个字符(即后缀名)的小写与2003版本文件一样
sRead_File_Conn = "[Excel 8.0;Database=" & sPath & sFile & "]."
'使用SQL语句打开非由oRead_Excel_Conn所定义的文件以外的文件，使用这种格式打开，注意别漏了后面的点
Else
sRead_File_Conn = "[Excel 12.0;Database=" & sPath & sFile & "]."
End If
If sExcel_Select <> "" Then
sExcel_Select = sExcel_Select & " Union All " '如果已经存在SQL语句，使用联合语句关联文件的连接
End If
sExcel_Select = sExcel_Select & "(Select " & sTitle & " From " & sRead_File_Conn & "[Sheet1$] " & sWhere & ")" '读取文件中Sheet1表
End If
sFile = Dir '查询一个符合条件的文件
Loop
ThisWorkbook.Activate '本工作簿激活为使用状态
With Sheets("汇总") '对”汇总“表进行操作
.[F:I].ClearContents '清空汇总表内的F:I列数据
vTitle = Split(sTitle, ",") '将所有标题用,隔开的字符串根据,分离成数组
.[F1:I1] = vTitle '通过以逗号为拆分词来拆分字符串所得的数组赋值给F1:I1单元格作为标题
.[F2].CopyFromRecordset oRead_Excel_Conn.Execute(sExcel_Select) '执行SQL语句并赋值到F2为起始的单元格区域
End With '结束对”汇总“表进行操作
oRead_Excel_Conn.Close '关闭文件SQL连接
Set oRead_Excel_Conn = Nothing '清除对象的SQL属性
Application.ScreenUpdating = True
End Sub

复制代码

microyip · 发表于 2016-11-9 08:29

使用数组处理多表汇总的解决方案

Sub 数组查找工作表汇总()
Dim wSH As Worksheet '定义工作表的变量
Dim vReadData As Variant '定义读取工作表的数据的数组变量
Dim vData As Variant '定义读取工作表的规范格式数据的数组变量
Dim nRow As Double '定义行数变量
Dim nCol As Integer '定义列数变量
Dim bAdd As Boolean '定义是否需要作为新记录添加的逻辑变量
Dim vFill As Variant '定义将要作为查询结果的数组变量
Dim nFill As Double '定义查询结果数组的行数的变量
Dim sName As String, sPlace As String, sArea As String, vAge As Variant
Dim vTitle As Variant '定义标题变量
Application.ScreenUpdating = False '禁止数据更新，避免因数据更新时引起闪屏，提高运行速度
vTitle = Split("姓名|年龄|籍贯|区域", "|") '将所有标题用|隔开的字符串根据|分离成数组
sName = Trim([A2]) '获取查询姓名的条件
sPlace = Trim([A6]) '获取查询籍贯的条件
sArea = Trim([A8]) '获取查询区域的条件
vAge = [A4:B4].Value '获取查询年龄的条件
ReDim vFill(1 To 4, 1 To 1) '定义一个4列1行的数组
'注意：正常填到表格内的数组是按(行，列)来定义的，因为考虑到行数将不断增加，而且数组只能是最后一个维度上进行变化，所以先将行定义在后面
For Each wSH In Sheets '查找工作簿中的每一个表
If wSH.Name <> "汇总" Then '如果找到的工作表的标签名不等于“汇总”
vReadData = wSH.UsedRange.Value '将工作表的所有已用单元格的数值赋值给数组
vData = 规范数据格式(vReadData, vTitle) '如果所有工作表内数据格式一致，可以跳过本步，上一步的赋值给vReadData的时候直接赋值给vData即可
For nRow = 2 To UBound(vData) 'vData中，第1行是标题，故从2行开始读取数据
bAdd = True '初始化变量为真
If sName <> "" Then bAdd = bAdd And (vData(nRow, 1) Like "*" & sName & "*")
'假如存在姓名条件，且姓名类似条件形式，为真，并跟bAdd进行与运算，例如：条件是”张“，那么”张三“就类似”*张*“
If vAge(1, 2) <> "" Then bAdd = bAdd And Application.Evaluate(vData(nRow, 2) & IIf(vAge(1, 1) = "", "=", vAge(1, 1)) & vAge(1, 2))
'Evaluate是计算一个字符串形式的式子的值
'IIf(vAge(1, 1) = "", "=", vAge(1, 1)) ,如果年龄的比较符号vAge(1, 1)没有被选择，默认使用等于号
'整个语句就是当条件中有年龄条件数值，对比数据中年龄vData(nRow, 2)是否符合条件
If sPlace <> "" Then bAdd = bAdd And (vData(nRow, 1) = sPlace)
'假如存在籍贯条件，且籍贯与条件相同，为真，并跟bAdd进行与运算
If sArea <> "" Then bAdd = bAdd And (vData(nRow, 1) = sArea)
'假如存在区域条件，且区域与条件相同，为真，并跟bAdd进行与运算
If bAdd Then '假如条件符合判断逻辑变量bAdd为真时
nFill = nFill + 1 '为查询数据数组的行数增加一行
ReDim Preserve vFill(1 To 4, 1 To nFill) '为增加一行的查询数据数组重定义
For nCol = 1 To 4
vFill(nCol, nFill) = vData(nRow, nCol) '复制符合条件的一行数据到查询数据数组最后一行上
Next
End If
Next
End If
Next
With Sheets("汇总") '对”汇总“表进行操作
.[F:I].ClearContents '清空汇总表内的F:I列数据
.[F1:I1] = Split("姓名,年龄,籍贯,区域", ",") '通过以逗号为拆分词来拆分字符串所得数组赋值给F1:I1单元格作为标题
If nFill > 0 Then '假如查询数据数组的记录行数大于0，即表示有数据
.[F2].Resize(nFill, 4) = Application.WorksheetFunction.Transpose(vFill)
'因为前面定义vFill时按（列，行）定义的，需要通过系统的转置函数Transpose转置为（行，列）数组
'赋值给由F2开始变形为nFill行，4列的单元格区域
End If
End With '结束对”汇总“表进行操作
Application.ScreenUpdating = True
End Sub

复制代码

microyip · 发表于 2016-11-9 08:29

使用SQL处理多表汇总的解决方案

Sub SQL查找工作表汇总()
Dim wSH As Worksheet '定义工作表的变量
Dim oRead_Excel_Conn As Object '定义数据集对象变量
Dim sExcel_Select As String '定义EXCEL读取数据SQL语句变量
Dim sRead_File_Conn As String '定义读文件的SQL语句连接变量
Dim sWhere As String 'SQL语句的条件部分变量
Dim sName As String, sPlace As String, sArea As String, vAge As Variant
Dim sTitle As Variant '定义SQL查找的标题变量
Dim vTitle As Variant '定义标题变量
Application.ScreenUpdating = False '禁止数据更新，避免因数据更新时引起闪屏，提高运行速度
sTitle = "姓名,年龄,籍贯,区域"
sName = Trim([A2]) '获取查询姓名的条件
sPlace = Trim([A6]) '获取查询籍贯的条件
sArea = Trim([A8]) '获取查询区域的条件
vAge = [A4:B4].Value '获取查询年龄的条件
sWhere = "Where True" '初始SQL的条件语句
If sName <> "" Then sWhere = sWhere & " And [姓名] Like '%" & sName & "%'"
'假如存在姓名条件，定义姓名类似条件给sWhere
If vAge(1, 2) <> "" Then sWhere = sWhere & " And [年龄]" & IIf(vAge(1, 1) = "", "=", vAge(1, 1)) & vAge(1, 2)
'IIf(vAge(1, 1) = "", "=", vAge(1, 1)) ,如果年龄的比较符号vAge(1, 1)没有被选择，默认使用等于号
'假如存在年龄条件，定义年龄对应关系条件给sWhere
If sPlace <> "" Then sWhere = sWhere & " And [籍贯]='" & sPlace & "'"
'假如存在籍贯条件，定义籍贯相等条件给sWhere
If sArea <> "" Then sWhere = sWhere & " And [区域]='" & sArea & "'"
'假如存在区域条件，且区域相等条件给sWhere
Set oRead_Excel_Conn = CreateObject("Adodb.Connection") '建立读EXCEL数据SQL数据集
If Val(Application.Version) < 12 Then '获取Excel的版本号，低于12为Excel2003版及以下，否则为Excel2007版及以上
oRead_Excel_Conn.Open "Provider=Microsoft.Jet.Oledb.4.0;Extended Properties=Excel 8.0;Data Source=" & ThisWorkbook.FullName '建立数据库连接，Excel2003版及以下
Else
oRead_Excel_Conn.Open "Provider=Microsoft.ACE.OLEDB.12.0;Extended Properties=Excel 12.0;Data Source=" & ThisWorkbook.FullName '建立数据库连接，Excel2007版及以上
End If
For Each wSH In Sheets '查找工作簿中的每一个表
If wSH.Name <> "汇总" Then '如果找到的工作表的标签名不等于“汇总”
If sExcel_Select <> "" Then
sExcel_Select = sExcel_Select & " Union All " '如果已经存在SQL语句，使用联合语句关联工作表的连接
End If
sExcel_Select = sExcel_Select & "(Select " & sTitle & " From [" & wSH.Name & "$] " & sWhere & ")" '读取工作表
End If
Next
With Sheets("汇总") '对”汇总“表进行操作
.[F:I].ClearContents '清空汇总表内的F:I列数据
vTitle = Split(sTitle, ",") '将所有标题用,隔开的字符串根据,分离成数组
.[F1:I1] = vTitle '通过以逗号为拆分词来拆分字符串所得的数组赋值给F1:I1单元格作为标题
.[F2].CopyFromRecordset oRead_Excel_Conn.Execute(sExcel_Select) '执行SQL语句并赋值到F2为起始的单元格区域
End With '结束对”汇总“表进行操作
oRead_Excel_Conn.Close '关闭文件SQL连接
Set oRead_Excel_Conn = Nothing '清除对象的SQL属性
Application.ScreenUpdating = True
End Sub

复制代码

microyip · 发表于 2016-11-11 21:49

jsgj2023 发表于 2016-11-11 21:16
顶一个，楼主写的代码好规范。

平时养成好习惯很重要
1、定义好变量
2、属性配对，各种属性关系使用陷入方式，按Tab键内进一下
If……End If
For……Next
Do While……Loop
With……End With等之间语句用陷入一些的方式
在查找Bug和维护时很有用

acjt7 · 发表于 2018-8-15 22:24

找到Office 2016 SQL 无法使用的方法了：
具体参考网址：https://blog.csdn.net/lwj3326/article/details/79337514

文字部分如下：
解决 'Microsoft .ACE.OLEDB.16.0'提供程序未在本地计算机上注册
2018年02月19日 17:28:53
阅读数：2449
使用SQLserver2016遇见这个问题
'Microsoft .ACE.OLEDB.16.0'提供程序未在本地计算机上注册
解决办法：

下载并安装：http://www.microsoft.com/download/en/confirmation.aspx?id=23734

无论您要访问/导入哪个文件，请确保将其选为Office 2010文件（即使可能是Office 2016文件）

microyip · 发表于 2016-11-12 07:52

yeminqiang 发表于 2016-11-11 23:19
大神，我用了你的代码，提示下标越界？怎么回事？

直接在我原来附件上出错？

microyip · 发表于 2016-11-12 10:50

yeminqiang 发表于 2016-11-12 10:37
呃，兄台太认真了。这代码我也会抄的。只不过调侃一下那些伸手党而已。

哦，抱歉，误会了。就是见太多伸手党，所以才做个模版给他们自己研究一下，也注释好给他们，这样也不会抄的话，真是无奈了

microyip · 发表于 2016-11-24 08:23

aman1516 发表于 2016-11-23 22:39
看熟代码三百个，不会编程也会抄……
对于新手，变量的名称也太长太难记了——说笑呢
楼主代码写得很规范 ...

抱歉，的确代码名称是有点长，但个人习惯问题，尽量在变量那里定义好类型，例如n代表数值，s代表字符串,o代表对象,v代表可变形变量……等等，同时变量名字也尽量在用的时候知道是什么意思，例如nRow是行，dStartDate是开始日期等

		自动登录	找回密码
密码			免费注册

[分享] 多工作簿多表查询汇总的通用解决方案

评分

评分

评分

评分

评分

评分

评分

评分

评分

最新热点 /1