请大神看看汇总多表问题代码

逆天修炼

各位路过的大神帮忙看看下面这张表，主要在“汇总表”这个工作表"汇总各工作表宏"，我觉得代码写的应该有问题，请大神帮忙看看有何错误，或者重与一段代码，谢谢！

各分表中的“项目名称”，“规格型号”，”单位“，三者合并作为字典去重条件合并到”汇总表“里

longwin

汇总代码重写如下：
Sub hz()
Set d = CreateObject("scripting.dictionary")
For Each sh In Sheets
    If InStr(1, sh.Name, "对比表") > 0 Then
    arr = sh.Range("c6:M" & sh.[A6].End(4).Row)
        For i = 1 To UBound(arr)
            ss = arr(i, 1) & "|" & arr(i, 2) & "|" & arr(i, 3)
            mc = sh.Name
            jg = Array(arr(i, 7), arr(i, 11))
            If Not d.exists(ss) Then Set d(ss) = CreateObject("scripting.dictionary")
            If Not d(ss).exists(mc) Then Set d(ss)(mc) = CreateObject("scripting.dictionary")
            d(ss)(mc) = jg
        Next
     End If
Next

ReDim brr(1 To d.Count, 1 To 18)
For Each Key In d.keys
    m = m + 1
    brr(m, 1) = m
    brr(m, 2) = Split(Key, "|")(0)
    brr(m, 3) = Split(Key, "|")(1)
    brr(m, 4) = Split(Key, "|")(2)
        For j = 5 To 17 Step 2
            mc = ((j - 3) / 2) & "#楼人材机审核对比表"
            If ((j - 3) / 2) = 7 Then mc = "地下室人材机审核对比表"
            If d(Key).exists(mc) Then
                brr(m, j) = d(Key)(mc)(0)
                brr(m, j + 1) = d(Key)(mc)(1)
            End If
        Next
Next
Sheets("汇总表").Range("A3:R" & Sheets("汇总表").[A2].End(4).Row).ClearContents
Sheets("汇总表").[A3].Resize(m, 18) = brr
End Sub

逆天修炼

longwin 发表于 2024-6-18 19:59
汇总代码重写如下：
Sub hz()
Set d = CreateObject("scripting.dictionary")

感谢longwin兄，你的代码功能很强大，里面用了3个嵌套字典，估计我得花点时间消化

wang-way

逆天修炼 发表于 2024-6-18 23:42
感谢longwin兄，你的代码功能很强大，里面用了3个嵌套字典，估计我得花点时间消化

看看我的

wang-way

ykcbf1100

多表合并，附件供参考。。。

ykcbf1100

参与一下。。。

1. Sub ykcbf()  '//2024.6.19   多表排重汇总
   
2.     Application.ScreenUpdating = False
   
3.     Set d = CreateObject("Scripting.Dictionary")
   
4.     Set d1 = CreateObject("Scripting.Dictionary")
   
5.     Set sh = ThisWorkbook.Sheets("汇总表")
   
6.     sh.UsedRange.Offset(52).ClearContents
   
7.     For Each sht In Sheets
   
8.         If InStr(sht.Name, "对比表") Then
   
9.             With sht
   
10.                 r = .Cells(Rows.Count, 1).End(3).Row
    
11.                 arr = .[a1].Resize(r, 17)
    
12.                 For i = 6 To UBound(arr)
    
13.                     If Val(arr(i, 1)) Then
    
14.                         s = arr(i, 3) & "|" & arr(i, 4) & "|" & arr(i, 5)
    
15.                         d1(s) = ""
    
16.                         s = arr(i, 3) & "|" & arr(i, 4) & "|" & arr(i, 5) & "|" & .Name
    
17.                         If Not d.exists(s) Then
    
18.                             d(s) = Array(arr(i, 9), arr(i, 13))
    
19.                         End If
    
20.                     End If
    
21.                 Next
    
22.             End With
    
23.         End If
    
24.     Next
    
25.     ReDim brr(1 To d1.Count, 1 To 4)
    
26.     For Each k In d1.keys
    
27.         m = m + 1
    
28.         t = Split(k, "|")
    
29.         brr(m, 1) = m
    
30.         brr(m, 2) = t(0)
    
31.         brr(m, 3) = t(1)
    
32.         brr(m, 4) = t(2)
    
33.     Next
    
34.     With sh
    
35.         .[a53].Resize(m, 4) = brr
    
36.         r = .Cells(Rows.Count, 1).End(3).Row
    
37.         For i = 53 To r
    
38.             For j = 5 To 18 Step 2
    
39.                 s = .Cells(i, 2) & "|" & .Cells(i, 3) & "|" & .Cells(i, 4) & "|" & .Cells(52, j)
    
40.                 If d.exists(s) Then
    
41.                     .Cells(i, j) = d(s)(0)
    
42.                     .Cells(i, j + 1) = d(s)(1)
    
43.                 End If
    
44.             Next
    
45.         Next
    
46.     End With
    
47.     Application.ScreenUpdating = True
    
48.     MsgBox "OK！"
    
49. End Sub
    

复制代码