如何将多个工作簿中多个工作表分别汇总到一个汇总表的对应位置

achalayatan · 发表于 2020-3-24 22:35

比如说附件中的a公司，b公司，c公司，d公司分别在工作簿中的相应位置填写了信息，我想要把abcd公司的信息汇总到汇总表中的相应位置，能不能实现，求大神帮助

awp57 · 发表于 2020-3-24 23:10

本帖最后由 awp57 于 2020-3-25 10:04 编辑

我试试看吧

awp57 · 发表于 2020-3-25 00:18

本帖最后由 awp57 于 2020-3-25 10:03 编辑

你自己测试吧

约定的童话 · 发表于 2020-3-25 08:41

简单的汇总到一个工作簿网上有现成代码，一些工具箱也可以

awp57 · 发表于 2020-3-25 23:10

Dim i, j, k, l, m, o, p As Integer
Sub 合并1()
'Application.ScreenUpdating = False '关闭屏幕更新
On Error GoTo 100
l = 1 '第1列设为判断条件
m = 2 '第2列设为判断条件
o = 4 '设定范围的开始列
p = 7 '设定范围的结束列
k = 4 '设定从第4行开始
Call 开始
Sheets(2).Select '触发第2个表
l = 1 '第1列设为判断条件
m = 2 '第2列设为判断条件
o = 4 '设定范围的开始列
p = 14 '设定范围的结束列
k = 4 '设定从第4行开始
Call 开始
Sheets(3).Select '触发第3个表
l = 1 '第1列设为判断条件
m = 2 '第2列设为判断条件
o = 4 '设定范围的开始列
p = 8 '设定范围的结束列
k = 4 '设定从第4行开始
Call 开始
Sheets(4).Select '触发第4个表
l = 1 '第1列设为判断条件
m = 2 '第2列设为判断条件
o = 4 '设定范围的开始列
p = 12 '设定范围的结束列
k = 4 '设定从第4行开始
Call 开始
Sheets(5).Select '触发第5个表
l = 1 '第1列设为判断条件
m = 2 '第2列设为判断条件
o = 3 '设定范围的开始列
p = 12 '设定范围的结束列
k = 5 '设定从第5行开始
Call 开始
Sheets(6).Select '触发第6个表
l = 1 '第1列设为判断条件
m = 2 '第2列设为判断条件
o = 3 '设定范围的开始列
p = 12 '设定范围的结束列
k = 6 '设定从第6行开始
Call 开始
Sheets(1).Select
Range("A1").Select
MsgBox "合并完成"
End
100:
ActsheetName = ActiveSheet.Name '获取当前工作表的表名
MsgBox "<" & ActsheetName & "> 工作表名不一样"
End Sub 'End子程序
Sub 开始()
Dim Mypath$, Myname$ '定义变量 Mypath$,Myname$
Dim Wb As Workbook '定义变量 Wb 为工作簿
Dim Ws As Worksheet '定义变量 Ws 为工作表
ActsheetName = ActiveSheet.Name '获取当前工作表的表名
Dim Myrng As Range '定义变量 Myrng 为单元格区域
Set d = CreateObject("scripting.dictionary") '设定d=创建对象("scripting.dictionary")
With Sheets(ActsheetName) '工作于表单集合("获得的工作表名")
r = .Cells(.Rows.Count, 1).End(3).Row 'r = .Cells(.Rows.Count, 1).End(3).Row
For i = k To r '设定变量范围为i=4到r 从第4行到最后一行
d(.Cells(i, l).Value & "-" & .Cells(i, m).Value) = i '条件第l列第m列
Next '下一个
End With 'End工作于
Mypath = ThisWorkbook.Path & "" 'Mypath=ThisWorkbook.Path & ""
Myname = Dir(Mypath & "*.xls*") 'Myname=下一个文件(Mypath & "*.xls*")
'
Do While Myname <> "" '执行循环操作当条件 Myname<>""
If Myname <> ThisWorkbook.Name Then '如果 Myname<>ThisWorkbook.Name 则执行
Set Wb = GetObject(Mypath & Myname) '设定Wb=GetObject(Mypath & Myname)
With Wb.Sheets(ActsheetName) '工作于Wb.Sheets("获得的工作表名")
Set Myrng = .Range("a1").CurrentRegion '设定Myrng=.Range("a2").CurrentRegion
With Myrng '工作于Myrng
arr = .Offset(1, 0).Resize(.Rows.Count - 1, .Columns.Count) '偏移B1 （修正回来）
End With 'End工作于
End With 'End工作于
With ThisWorkbook.Sheets(ActsheetName) '工作于ThisWorkbook.Sheets("获得的工作表名")
For i = 1 To UBound(arr) '设定变量范围为i=1到UBound(arr)
If d.exists(arr(i, l) & "-" & arr(i, m)) Then '如果 d.exists(arr(i,4) & "-" & arr(i,5)) 则执行
For j = o To p '设定变量范围为j=8到16
If .Cells(d(arr(i, l) & "-" & arr(i, m)), j) = "" And arr(i, j) <> "" Then
.Cells(d(arr(i, l) & "-" & arr(i, m)), j) = arr(i, j) '.Cells(d(arr(i,4) & "-" & arr(i,5)),j)=arr(i,j)
End If 'End如果
Next '下一个
End If 'End如果
Next '下一个
End With 'End工作于
Erase arr '删除arr
Wb.Close 'Wb.Close
End If 'End如果
Myname = Dir 'Myname=下一个文件
Loop '循环执行
End Sub

复制代码

awp57 · 发表于 2020-3-25 23:11

Dim i, j, k, l, m, o, p As Integer
Sub 合并1()
'Application.ScreenUpdating = False '关闭屏幕更新
On Error GoTo 100
l = 1 '第1列设为判断条件
m = 2 '第2列设为判断条件
o = 4 '设定范围的开始列
p = 7 '设定范围的结束列
k = 4 '设定从第4行开始
Call 开始
Sheets(2).Select '触发第2个表
l = 1 '第1列设为判断条件
m = 2 '第2列设为判断条件
o = 4 '设定范围的开始列
p = 14 '设定范围的结束列
k = 4 '设定从第4行开始
Call 开始
Sheets(3).Select '触发第3个表
l = 1 '第1列设为判断条件
m = 2 '第2列设为判断条件
o = 4 '设定范围的开始列
p = 8 '设定范围的结束列
k = 4 '设定从第4行开始
Call 开始
Sheets(4).Select '触发第4个表
l = 1 '第1列设为判断条件
m = 2 '第2列设为判断条件
o = 4 '设定范围的开始列
p = 12 '设定范围的结束列
k = 4 '设定从第4行开始
Call 开始
Sheets(5).Select '触发第5个表
l = 1 '第1列设为判断条件
m = 2 '第2列设为判断条件
o = 3 '设定范围的开始列
p = 12 '设定范围的结束列
k = 5 '设定从第5行开始
Call 开始
Sheets(6).Select '触发第6个表
l = 1 '第1列设为判断条件
m = 2 '第2列设为判断条件
o = 3 '设定范围的开始列
p = 12 '设定范围的结束列
k = 6 '设定从第6行开始
Call 开始
Sheets(1).Select
Range("A1").Select
MsgBox "合并完成"
End
100:
ActsheetName = ActiveSheet.Name '获取当前工作表的表名
MsgBox "<" & ActsheetName & "> 工作表名不一样"
End Sub 'End子程序
Sub 开始()
Dim Mypath$, Myname$ '定义变量 Mypath$,Myname$
Dim Wb As Workbook '定义变量 Wb 为工作簿
Dim Ws As Worksheet '定义变量 Ws 为工作表
ActsheetName = ActiveSheet.Name '获取当前工作表的表名
Dim Myrng As Range '定义变量 Myrng 为单元格区域
Set d = CreateObject("scripting.dictionary") '设定d=创建对象("scripting.dictionary")
With Sheets(ActsheetName) '工作于表单集合("获得的工作表名")
r = .Cells(.Rows.Count, 1).End(3).Row 'r = .Cells(.Rows.Count, 1).End(3).Row
For i = k To r '设定变量范围为i=4到r 从第4行到最后一行
d(.Cells(i, l).Value & "-" & .Cells(i, m).Value) = i '条件第l列第m列
Next '下一个
End With 'End工作于
Mypath = ThisWorkbook.Path & "" 'Mypath=ThisWorkbook.Path & ""
Myname = Dir(Mypath & "*.xls*") 'Myname=下一个文件(Mypath & "*.xls*")
'
Do While Myname <> "" '执行循环操作当条件 Myname<>""
If Myname <> ThisWorkbook.Name Then '如果 Myname<>ThisWorkbook.Name 则执行
Set Wb = GetObject(Mypath & Myname) '设定Wb=GetObject(Mypath & Myname)
With Wb.Sheets(ActsheetName) '工作于Wb.Sheets("获得的工作表名")
Set Myrng = .Range("a1").CurrentRegion '设定Myrng=.Range("a2").CurrentRegion
With Myrng '工作于Myrng
arr = .Offset(1, 0).Resize(.Rows.Count - 1, .Columns.Count) '偏移B1 （修正回来）
End With 'End工作于
End With 'End工作于
With ThisWorkbook.Sheets(ActsheetName) '工作于ThisWorkbook.Sheets("获得的工作表名")
For i = 1 To UBound(arr) '设定变量范围为i=1到UBound(arr)
If d.exists(arr(i, l) & "-" & arr(i, m)) Then '如果 d.exists(arr(i,4) & "-" & arr(i,5)) 则执行
For j = o To p '设定变量范围为j=8到16
If .Cells(d(arr(i, l) & "-" & arr(i, m)), j) = "" And arr(i, j) <> "" Then
.Cells(d(arr(i, l) & "-" & arr(i, m)), j) = arr(i, j) '.Cells(d(arr(i,4) & "-" & arr(i,5)),j)=arr(i,j)
End If 'End如果
Next '下一个
End If 'End如果
Next '下一个
End With 'End工作于
Erase arr '删除arr
Wb.Close 'Wb.Close
End If 'End如果
Myname = Dir 'Myname=下一个文件
Loop '循环执行
End Sub

复制代码

awp57 · 发表于 2020-3-25 23:12

代码格式千奇百怪，初来乍到老师们不要笑我

achalayatan · 发表于 2020-3-26 22:03

awp57 发表于 2020-3-25 23:12
代码格式千奇百怪，初来乍到老师们不要笑我

感谢大佬分享

yangweisc · 发表于 2020-4-1 09:38

谢谢分享，受教了

LighOffice · 发表于 2020-4-20 11:44

http://club.excelhome.net/forum.php?mod=viewthread&tid=1531207&mobile=2

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