数据合并问题求助（上一帖子数据不全，重新发帖求助）

hlw2008

上一帖子数据不全面，个别地方有错，重新发帖求助。感谢各位大神的帮助。。


数据合并，非汇总计算。。

hlw2008

感谢大家的帮助！

hlw2008

哪位大神帮助解决一下问题，

hlw2008

谢谢大家观看，自乐一下

ykcbf1100

hlw2008 发表于 2023-6-28 09:52
谢谢大家观看，自乐一下

汇总表中，BCD三列数据是自动生成的，还是汇总表本来就有？

shiruiqiang

看表格，我的感觉和你不一样，字典不同
其次，项目栏是否已存在

ykcbf1100

参与一下。

chxw68

1. Sub test()
   
2.     Dim r%, i%, m%, n%
   
3.     Dim arr, brr
   
4.     Dim ws As Worksheet
   
5.     Dim d As Object
   
6.     Set d = CreateObject("scripting.dictionary")
   
7.     n = 6
   
8.     For Each ws In Worksheets(Array("2021", "2022"))
   
9.         With ws
   
10.             r = .Cells(.Rows.Count, 2).End(xlUp).Row
    
11.             arr = .Range("a2:k" & r)
    
12.             For i = 1 To UBound(arr)
    
13.                 xm = arr(i, 3) & "+" & arr(i, 5) & "+" & arr(i, 11)
    
14.                 If Not d.exists(xm) Then
    
15.                     ReDim brr(1 To 17)
    
16.                     brr(2) = arr(i, 2)
    
17.                     brr(3) = arr(i, 3)
    
18.                     brr(4) = arr(i, 4)
    
19.                     brr(5) = arr(i, 5)
    
20.                 Else
    
21.                     brr = d(xm)
    
22.                 End If
    
23.                 For j = 6 To UBound(arr, 2)
    
24.                     brr(n + j - 6) = arr(i, j)
    
25.                 Next
    
26.                 d(xm) = brr
    
27.             Next
    
28.         End With
    
29.         n = n + 6
    
30.     Next
    
31.     With Worksheets("合并汇总")
    
32.         .UsedRange.Offset(1, 0).Clear
    
33.         With .Range("a2").Resize(d.Count, 17)
    
34.             .Value = Application.Transpose(Application.Transpose(d.items))
    
35.             .Borders.LineStyle = xlContinuous
    
36.         End With
    
37.     End With
    
38. End Sub
    

复制代码

chxw68

参与一下。