求助：如何合并数据

prowl

希望，在“总表”的相应位置里汇总其他四个表的内容：
1、“总表”名称列汇总4个表的内容，如果遇到重复的就合并为一个数据，“数量”那列，能够得到其他四个sheet里相应内容汇总后的数量

比如：苹果在“北店”、“南店”、“西店”都有，则，在“总表”的“名称”列就显示一个苹果就行，“数量“直接得出67
但是：在“总表”中的“北店”列下面对应苹果显示5，“南店”列下面对应苹果显示50，”西店“列下面对应苹果显示12
以此类推。就是四个表的各个单元格内容，在”总表“相应列下具体全部显示出
2、希望四个表里如果有数据变动，比如：“名称”和“数量”增加或者减少时，在总表中就可以自动发生变化。
3、如果增加了sheet表，在“总表”里也会有相应的自动数据变化。
先谢谢老师了

shiruiqiang

一维转二维，全自动生成统计

ykcbf1100

转换。。。。

ykcbf1100

参与一下。。。

1. Sub ykcbf()   '//2024.12.7
   
2.     Application.ScreenUpdating = False
   
3.     Application.DisplayAlerts = False
   
4.     Set d = CreateObject("Scripting.Dictionary")
   
5.     Set sh = ThisWorkbook.Sheets("总表")
   
6.     ReDim brr(1 To 10000, 1 To 100)
   
7.     m = 1: n = 3
   
8.     On Error Resume Next
   
9.     For Each sht In Sheets
   
10.         If sht.Name <> sh.Name Then
    
11.             n = n + 1
    
12.             With sht
    
13.                 r = .Cells(Rows.Count, 1).End(3).Row
    
14.                 arr = .[a1].Resize(r, 3)
    
15.                 brr(1, n) = arr(1, 1)
    
16.             End With
    
17.             If n = 4 Then
    
18.                 For j = 1 To 3
    
19.                     brr(1, j) = arr(2, j)
    
20.                 Next
    
21.             End If
    
22.             For i = 3 To UBound(arr)
    
23.                 s = arr(i, 1)
    
24.                 If Not d.exists(s) Then
    
25.                     m = m + 1
    
26.                     d(s) = m
    
27.                     brr(m, 1) = arr(i, 1)
    
28.                     brr(m, 2) = arr(i, 2)
    
29.                 End If
    
30.                 r = d(arr(i, 1))
    
31.                 brr(r, n) = brr(r, n) + arr(i, 3)
    
32.             Next
    
33.         End If
    
34.     Next
    
35.     With sh
    
36.         .UsedRange.Clear
    
37.         .Cells.Interior.ColorIndex = 0
    
38.         .[a1].Resize(1, n).Interior.Color = 49407
    
39.         .[a2].Resize(m - 1, 1).Interior.Color = 5296274
    
40.         With .[a1].Resize(m, n)
    
41.             .Value = brr
    
42.             .Borders.LineStyle = 1
    
43.             .HorizontalAlignment = xlCenter
    
44.             .VerticalAlignment = xlCenter
    
45.             With .Font
    
46.                 .Name = "微软雅黑"
    
47.                 .Size = 11
    
48.             End With
    
49.         End With
    
50.         For i = 2 To m
    
51.             .Cells(i, 3).Value = Application.Sum(.Cells(i, 3).Resize(, n - 2))
    
52.         Next
    
53.         .[c2].Resize(m - 1, n - 2).HorizontalAlignment = xlRight
    
54.         .[c2].Resize(m - 1, n - 2).NumberFormatLocal = "0.00"
    
55.         .Columns(3).NumberFormatLocal = "0"
    
56.     End With
    
57.     Application.ScreenUpdating = True
    
58.     MsgBox "OK！"
    
59. End Sub
    

复制代码

prowl

ykcbf1100 发表于 2024-12-7 19:48
参与一下。。。

感谢感谢老师

prowl

shiruiqiang 发表于 2024-12-7 18:57
一维转二维，全自动生成统计

感谢感谢帮忙

翁知江安

Sub 汇总()
Dim i, j, k, irow
Dim tepar, ar
Dim d1, d2 As Object
Set d1 = CreateObject("scripting.dictionary")
Set d2 = CreateObject("scripting.dictionary")
Dim sht As Worksheet
For Each sht In ThisWorkbook.Worksheets
  If sht.Name <> "总表" Then
     irow = sht.[a65536].End(xlUp).Row
     tepar = sht.Range("a1:c" & irow)
     For i = 3 To irow
     d1(tepar(i, 1) & tepar(1, 1)) = d1(tepar(i, 1) & tepar(1, 1)) + tepar(i, 3)
     d2(tepar(i, 1)) = d2(tepar(i, 1)) + tepar(i, 3)
     Next
   End If
Next
With Sheets("总表")
  .[a2].Resize(d2.Count, 1) = WorksheetFunction.Transpose(d2.keys)
  .[c2].Resize(d2.Count, 1) = WorksheetFunction.Transpose(d2.items)
  ReDim ar(1 To d2.Count, 1 To Sheets.Count - 1)
  For j = 2 To d2.Count + 1
     For k = 5 To 8
      ar(j - 1, k - 4) = d1(.Cells(j, 1).Value & .Cells(1, k).Value)
     Next
  Next
  .[e2].Resize(d2.Count, 4) = ar
  End With
  MsgBox "ok"
  Set d1 = Nothing: Set d2 = Nothing
End Sub

翁知江安

供参考，欢迎批评指正。

翁知江安

Sub 汇总()
Dim i, j, k, irow
Dim tepar, ar
Dim d1, d2 As Object
Set d1 = CreateObject("scripting.dictionary")
Set d2 = CreateObject("scripting.dictionary")
Dim sht As Worksheet
For Each sht In ThisWorkbook.Worksheets
  If sht.Name <> "总表" Then
     irow = sht.[a65536].End(xlUp).Row
     tepar = sht.Range("a1:c" & irow)
     For i = 3 To irow
     d1(tepar(i, 1) & tepar(1, 1)) = d1(tepar(i, 1) & tepar(1, 1)) + tepar(i, 3)
     d2(tepar(i, 1)) = d2(tepar(i, 1)) + tepar(i, 3)
     Next
   End If
Next
With Sheets("总表")
  .[a2].Resize(d2.Count, 1) = WorksheetFunction.Transpose(d2.keys)
  .[c2].Resize(d2.Count, 1) = WorksheetFunction.Transpose(d2.items)
  ReDim ar(1 To d2.Count, 1 To Sheets.Count - 1)
  For j = 2 To d2.Count + 1
     For k = 5 To Sheets.Count + 4
      ar(j - 1, k - 4) = d1(.Cells(j, 1).Value & .Cells(1, k).Value)
     Next
  Next
  .[e2].Resize(d2.Count, UBound(ar, 2)) = ar
  End With
  MsgBox "ok"
  Set d1 = Nothing: Set d2 = Nothing
End Sub

翁知江安

略为修改了一下