同一工作簿下所有工作表按相同名称汇总求和

jjip123

同一工作簿下所有工作表按相同名称汇总求和， ，总表是产品名称 ，想把其他所有工作表里同个产品汇总求和。

，其他工作表为明细格式， 新建 XLSX 工作表 (3).7z (113.76 KB, 下载次数: 8)

2024-11-22 11:29 上传

点击文件名下载附件

超级拉风的小小

不知道是不是你的需求啊，你运行看看
Sub tt()
    Dim arr, brr
    Dim i, j, k, m As Long
    Dim sht As Worksheet
    Sheets("总表").Range("a1").CurrentRegion.Offset(2, 1).ClearContents
    arr = Sheets("总表").Range("a1").CurrentRegion
    Application.DisplayAlerts = False
    '删掉空表
    For Each sht In Sheets
        If Application.WorksheetFunction.CountA(sht.Cells) = 0 Then sht.Delete
    Next
    Application.DisplayAlerts = True
   
    For i = 3 To UBound(arr)
        For Each sht In Sheets
            If sht.Name <> "总表" Then
                brr = sht.Range("a1").CurrentRegion
                For j = 3 To UBound(brr)
                    If arr(i, 1) = brr(j, 1) Then
                        For k = 4 To UBound(brr, 2)
                            If arr(2, 2) = brr(2, k) Then arr(i, 2) = arr(i, 2) + brr(j, k)
                            If arr(2, 3) = brr(2, k) Then arr(i, 3) = arr(i, 3) + brr(j, k)
                            If arr(2, 4) = brr(2, k) Then arr(i, 4) = arr(i, 4) + brr(j, k)
                        Next
                    End If
                Next
            End If
        Next
    Next
    Sheet1.Range("a1").CurrentRegion = arr
End Sub

jjip123

超级拉风的小小 发表于 2024-11-22 12:40
不知道是不是你的需求啊，你运行看看
Sub tt()
    Dim arr, brr

谢谢，完全能满足需求！！！！

jjip123

jjip123 发表于 2024-11-22 14:22
谢谢，完全能满足需求！！！！

在汇总D列前面插入两列其他内容，再实现这个需要怎么修改？？

ykcbf1100

参与一下，附件供参考。。。

ykcbf1100

参与一下。。。

1. Sub ykcbf()    '//2024.11.22
   
2.     Application.ScreenUpdating = False
   
3.     Set d = CreateObject("Scripting.Dictionary")
   
4.     Set sh = ThisWorkbook.Sheets("总表")
   
5.     ReDim brr(1 To 100000, 1 To 100)
   
6.     For Each sht In Sheets
   
7.         If sht.Name <> sh.Name Then
   
8.             If sht.UsedRange.Count > 1 Then
   
9.                 arr = sht.UsedRange
   
10.                 r = sht.Columns(1).Find("合计").Row
    
11.                 For j = 4 To UBound(arr, 2) Step 3
    
12.                     For i = 3 To r - 3
    
13.                         If arr(i, j + 1) <> Empty Then
    
14.                             s = arr(i, 1)
    
15.                             If Not d.exists(s) Then
    
16.                                 m = m + 1
    
17.                                 d(s) = m
    
18.                                 brr(m, 1) = s
    
19.                                 brr(m, 2) = arr(i, j)
    
20.                                 brr(m, 3) = arr(i, j + 1)
    
21.                                 brr(m, 4) = arr(i, j + 2)
    
22.                             Else
    
23.                                 r = d(s)
    
24.                                 brr(r, 2) = brr(r, 2) + arr(i, j)
    
25.                                 brr(r, 3) = brr(r, 3) + arr(i, j + 1)
    
26.                                 brr(r, 4) = brr(r, 4) + arr(i, j + 2)
    
27.                             End If
    
28.                         End If
    
29.                     Next
    
30.                 Next
    
31.             End If
    
32.         End If
    
33.     Next
    
34.     With sh
    
35.         .UsedRange.Offset(2).ClearContents
    
36.         .[a3].Resize(m, 4) = brr
    
37.     End With
    
38.     Set d = Nothing
    
39.     Application.ScreenUpdating = True
    
40.     MsgBox "OK！"
    
41. End Sub
    
42. 
    

复制代码

jjmysjg

超级拉风的小小 发表于 2024-11-22 12:40
不知道是不是你的需求啊，你运行看看
Sub tt()
    Dim arr, brr

工作表内，重复的字段求和

jjip123

ykcbf1100 发表于 2024-11-22 19:35
参与一下。。。

大神，这个代码在统计的时候会把BCD三列的数据清空 ，能不能帮我改一下，再执行统计这个代码时，这三列有数据不清空！！！谢谢！！！！

jjip123

jjip123 发表于 2024-12-24 10:38
大神，这个代码在统计的时候会把BCD三列的数据清空 ，能不能帮我改一下，再执行统计这个代码时，这三列有 ...

在前面插入三列，然后统计，怎么才能不把前三列清空，然后后面依然能取数？

jjip123

前面插入三列，统计时这三列数据不清空，后面汇总项正常统计数据！