数据汇总的代码不够完善，希望有老师能帮帮忙

Glazes · 发表于 2019-11-29 09:14

本帖最后由 Glazes 于 2019-11-29 09:16 编辑

因为工作需要，在网上东拼西凑了一个用于多账簿多表格汇总的代码，但有些功能没办法实现，希望有老师能帮我改进代码。

希望改进的地方：
1.目前只能忽略每个表的表头，希望能忽略每张表的表头和表尾，比如：表格的前一行和最后两行不需要。
2.目前只能默认从A1单元格开始粘贴，希望能自主选择粘贴位置，因为前三列有别的数据，比如说从C1开始粘贴。
3.希望能在粘贴原表数据时，在原始数据前面三列添加其他的原创数据，比如，序号，公司名称，时间等，不过不能实现也没关系，可以后期手动添加。

如果老师在修改代码的时候能在改进的地方加上备注就更好了。

Sub 多簿多表合并()
Dim MyPath, MyName, AWbName
Dim Wb As Workbook, WbN As String
Dim G As Long
Dim Num As Long
Dim BOX As String
zdm = Application.InputBox("请输入汇总要匹配的列字段名：")
Application.ScreenUpdating = False '关闭屏幕更新
MyPath = ThisWorkbook.Path
MyName = Dir(MyPath & "" & "*.xls*")
AWbName = ThisWorkbook.Name
For Each CXrng In ActiveSheet.UsedRange '取消合并单元格
If CXrng.MergeCells Then
Set XRrng = CXrng.MergeArea
A = CXrng.MergeArea(1).Value
CXrng.UnMerge
XRrng.Value = A
End If
Next
Sheet1.UsedRange.Offset(0, 3).Clear '清除*行*列之外的所有内容
'Columns.Clear '表单清除
Num = 0
Do While MyName <> ""
If MyName <> AWbName Then
Set Wb = Workbooks.Open(MyPath & "" & MyName)
Num = Num + 1
With Workbooks(1).ActiveSheet
For G = 1 To Wb.Sheets.Count
Wb.Sheets(G).UsedRange.Offset(1, 0).Copy .Cells(.Range("a65536").End(xlUp).Row + n, 1)
n = (n + 1) ^ 0
Next
Wb.Close False '关闭工作簿且不保存
End With
End If
MyName = Dir '寻找下一个工作簿
Loop
Myr = Cells(Rows.Count, 1).End(xlUp).Row
Set Rng = ActiveSheet.UsedRange.Find(What:=zdm)
l = Rng.Column
For I = Myr To 2 Step -1
If Cells(I, l) = zdm Then Rows(I).Delete
Next
Application.ScreenUpdating = True '恢复屏幕更新
End Sub

复制代码

microyip · 发表于 2019-11-29 09:43

http://club.excelhome.net/thread-1310803-1-1.html 多表多工作簿汇总，参考变通一下

Glazes · 发表于 2019-11-29 11:54

有老师能帮帮忙吗？实在是搞不定了

Glazes · 发表于 2019-11-29 15:12

microyip 发表于 2019-11-29 09:43
http://club.excelhome.net/thread-1310803-1-1.html 多表多工作簿汇总，参考变通一下

老师你好，我按照您的代码修改了一下，但是实在是完成不了，又是工作任务，能帮我看一下吗？
我修改后的数组查找，提示下标越界了

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, sGas As Variant, sWater As Variant, sPliers As Variant, sGrab As Variant, sElectric As Variant, sCold As Variant, sSpray As Variant, sClip As Variant, sSilk As Variant, sKnife As Variant, sBall As Variant, sNet As Variant, sPipe As Variant, sOther As Variant, sTotal As Variant '*
Dim vTitle As Variant '定义标题变量
Application.ScreenUpdating = False '禁止数据更新，避免因数据更新时引起闪屏，提高运行速度
vTitle = Split("采购商品名称|送气|送水|活检钳|抓钳|电圈套器|冷圈套器|喷洒管|夹子|导丝|切开刀|球囊|网篮|引流管|其他|合计", "|") '将所有标题用|隔开的字符串根据|分离成数组'*
sName = Trim([B1]) '获取查询商品名称的条件
sGas = Trim([B2])
sWater = Trim([B3])
sPliers = Trim([B4])
sGrab = Trim([B5])
sElectric = Trim([B6])
sCold = Trim([B7])
sSpray = Trim([B8])
sClip = Trim([B9])
sSilk = Trim([B10])
sKnife = Trim([B11])
sBall = Trim([B12])
sNet = Trim([B13])
sPipe = Trim([B14])
sOther = Trim([B15])
sTotal = [B16].Value
ReDim vFill(1 To 16, 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 = 4 To UBound(vData) 'vData中，第1行是标题，故从2行开始读取数据
bAdd = True '初始化变量为真
If sName <> "" Then bAdd = bAdd And (vData(nRow, 1) = sName)
'假如存在姓名条件，且姓名类似条件形式，为真，并跟bAdd进行与运算，例如：条件是”张“，那么”张三“就类似”*张*“
If sGas <> "" Then bAdd = bAdd And (vData(nRow, 1) = sGas)
'If sGas(1, 2) <> "" Then bAdd = bAdd And Application.Evaluate(vData(nRow, 2) & IIf(sGas(1, 1) = "", "=", sGas(1, 1)) & sGas(1, 2))
'Evaluate是计算一个字符串形式的式子的值
'IIf(vAge(1, 1) = "", "=", vAge(1, 1)) ,如果年龄的比较符号vAge(1, 1)没有被选择，默认使用等于号
'整个语句就是当条件中有年龄条件数值，对比数据中年龄vData(nRow, 2)是否符合条件
If sWater <> "" Then bAdd = bAdd And (vData(nRow, 1) = sWater)
'假如存在籍贯条件，且籍贯与条件相同，为真，并跟bAdd进行与运算
If sPliers <> "" Then bAdd = bAdd And (vData(nRow, 1) = sPliers)
'假如存在区域条件，且区域与条件相同，为真，并跟bAdd进行与运算
If sGrab <> "" Then bAdd = bAdd And (vData(nRow, 1) = sGrab)
'假如存在籍贯条件，且籍贯与条件相同，为真，并跟bAdd进行与运算
If sElectric <> "" Then bAdd = bAdd And (vData(nRow, 1) = sElectric)
'假如存在区域条件，且区域与条件相同，为真，并跟bAdd进行与运算
If sCold <> "" Then bAdd = bAdd And (vData(nRow, 1) = sCold)
'假如存在籍贯条件，且籍贯与条件相同，为真，并跟bAdd进行与运算
If sSpray <> "" Then bAdd = bAdd And (vData(nRow, 1) = sSpray)
'假如存在区域条件，且区域与条件相同，为真，并跟bAdd进行与运算
If sClip <> "" Then bAdd = bAdd And (vData(nRow, 1) = sClip)
'假如存在籍贯条件，且籍贯与条件相同，为真，并跟bAdd进行与运算
If sSilk <> "" Then bAdd = bAdd And (vData(nRow, 1) = sSilk)
'假如存在区域条件，且区域与条件相同，为真，并跟bAdd进行与运算
If sKnife <> "" Then bAdd = bAdd And (vData(nRow, 1) = sKnife)
'假如存在区域条件，且区域与条件相同，为真，并跟bAdd进行与运算
If sBall <> "" Then bAdd = bAdd And (vData(nRow, 1) = sBall)
'假如存在区域条件，且区域与条件相同，为真，并跟bAdd进行与运算
If sNet <> "" Then bAdd = bAdd And (vData(nRow, 1) = sNet)
'假如存在区域条件，且区域与条件相同，为真，并跟bAdd进行与运算
If sPipe <> "" Then bAdd = bAdd And (vData(nRow, 1) = sPipe)
'假如存在区域条件，且区域与条件相同，为真，并跟bAdd进行与运算
If sOther <> "" Then bAdd = bAdd And (vData(nRow, 1) = sOther)
'假如存在区域条件，且区域与条件相同，为真，并跟bAdd进行与运算
If sTotal <> "" Then bAdd = bAdd And (vData(nRow, 1) = sTotal)
'假如存在区域条件，且区域与条件相同，为真，并跟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("sheet1") '对”汇总“表进行操作
.[F:U].ClearContents '清空汇总表内的F:I列数据
.[F1:U1] = 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
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

复制代码

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

[求助] 数据汇总的代码不够完善，希望有老师能帮帮忙

最新热点 /1