[已解决]求助各位老师，如何将不同表格相同位置的数值求和汇总到一个指定的表格中指定位置

乄蜗牛

求助一下论坛里的各位老师：
      现在有多个表格，每个表格中只含有一个内容结构相同的sheet（见下图），其中：
没有颜色填充的位置为固定格式；

颜色填充的位置中：红色区域不可填写数据信息，橙色位置为手动填写的数据，蓝色区域为橙色数据的计算结果。

表格内容

如何编写一个宏工具，将各个表格中相同位置的数据求和汇总到一个表格中，并且汇总数据的表格，拥有和其他表格相同的结构


数据表格.rar (16.43 KB, 下载次数: 10)

2021-9-30 14:33 上传

点击文件名下载附件
数据表格

最佳答案

月排行榜 / 总排行榜

风林火山

2021-9-30 14:30

1. Sub 合并() '先选择一个需要汇总的工作簿，把代码放到这个工作簿模块中，然后在选择其他需要汇总的工作簿（不包括先打开的工作簿）
   
2.     Dim arr, brr, crr, k As Byte, m As Byte, n As Byte, wk As Workbook
   
3.     ActiveWorkbook.SaveAs ThisWorkbook.Path & "" & "数据汇总.xlsm"
   
4.     brr = Range("e7:o28")
   
5.     arr = Application.GetOpenFilename("Excel文件,*.xlsx*", 2, , , True)
   
6.     If IsArray(arr) = False Then Exit Sub
   
7.     For k = 1 To UBound(arr)
   
8.         Set wk = Workbooks.Open(arr(k))
   
9.         crr = Range("e7:o28")
   
10.         For m = 1 To UBound(brr)
    
11.             For n = 1 To UBound(brr, 2)
    
12.                 brr(m, n) = brr(m, n) + crr(m, n)
    
13.             Next n
    
14.         Next m
    
15.         Erase crr
    
16.         wk.Close 0
    
17.         Set wk = Nothing
    
18.     Next k
    
19.     Range("e7").Resize(UBound(brr), UBound(brr, 2)) = brr
    
20. End Sub
    

复制代码

跳转到最佳答案楼层

风林火山

1. Sub 合并() '先选择一个需要汇总的工作簿，把代码放到这个工作簿模块中，然后在选择其他需要汇总的工作簿（不包括先打开的工作簿）
   
2.     Dim arr, brr, crr, k As Byte, m As Byte, n As Byte, wk As Workbook
   
3.     ActiveWorkbook.SaveAs ThisWorkbook.Path & "" & "数据汇总.xlsm"
   
4.     brr = Range("e7:o28")
   
5.     arr = Application.GetOpenFilename("Excel文件,*.xlsx*", 2, , , True)
   
6.     If IsArray(arr) = False Then Exit Sub
   
7.     For k = 1 To UBound(arr)
   
8.         Set wk = Workbooks.Open(arr(k))
   
9.         crr = Range("e7:o28")
   
10.         For m = 1 To UBound(brr)
    
11.             For n = 1 To UBound(brr, 2)
    
12.                 brr(m, n) = brr(m, n) + crr(m, n)
    
13.             Next n
    
14.         Next m
    
15.         Erase crr
    
16.         wk.Close 0
    
17.         Set wk = Nothing
    
18.     Next k
    
19.     Range("e7").Resize(UBound(brr), UBound(brr, 2)) = brr
    
20. End Sub
    

复制代码

乄蜗牛

风林火山 发表于 2021-9-30 14:30

多谢老哥解决问题