vba 合并相同尺寸

zhangmy66

vba  合并相同尺寸，以厚度，长度，宽度为关键字，对数量合并

ykcbf1100

字典经典用法之一：排重汇总

Qs18

试试..........

ykcbf1100

参与一下。。。

1. Sub ykcbf()   '//2024.8.15
   
2.     Dim arr, brr, d
   
3.     Application.ScreenUpdating = False
   
4.     Set d = CreateObject("scripting.dictionary")
   
5.     With Sheets("测试数据")
   
6.         r = .Cells(Rows.Count, "h").End(3).Row
   
7.         arr = .[h1].Resize(r, 4)
   
8.     End With
   
9.     ReDim brr(1 To UBound(arr), 1 To 4)
   
10.     For i = 2 To UBound(arr)
    
11.         s = arr(i, 1) & "|" & arr(i, 2) & "|" & arr(i, 3)
    
12.         If Not d.Exists(s) Then
    
13.             m = m + 1
    
14.             d(s) = m
    
15.             For j = 1 To UBound(arr, 2)
    
16.                 brr(m, j) = arr(i, j)
    
17.             Next
    
18.         Else
    
19.             r = d(s)
    
20.             brr(r, 4) = brr(r, 4) + arr(i, 4)
    
21.         End If
    
22.     Next
    
23.     With Sheets("操作结果")
    
24.         .[h2].Resize(10000, 4) = ""
    
25.         .Range("h2").Resize(m, 4) = brr
    
26.     End With
    
27.     Set d = Nothing
    
28.     Application.ScreenUpdating = True
    
29.     MsgBox "OK！"
    
30. End Sub
    

复制代码

zhangmy66

ykcbf1100 发表于 2024-8-15 15:02
字典经典用法之一：排重汇总

这么快的速度

ykcbf1100

zhangmy66 发表于 2024-8-15 15:09
这么快的速度

这个简单。。。

Qs18

Sub qs()
Dim arr, i, dic
Set dic = CreateObject("scripting.dictionary")
arr = Sheet1.Range("h2:k" & Sheet1.Cells(Rows.Count, "k").End(xlUp).Row)
ReDim brr(1 To UBound(arr), 1 To UBound(arr, 2))
For i = 1 To UBound(arr)
    s = arr(i, 1) & "|" & arr(i, 2) & "|" & arr(i, 3)
    If Not dic.exists(s) Then
        m = m + 1
        dic(s) = m
        For j = 1 To 4
            brr(m, j) = arr(i, j)
        Next
    Else
        rw = dic(s)
        brr(rw, 4) = brr(rw, 4) + arr(i, 4)
    End If
Next
Sheet2.Range("h2").Resize(m, 4) = brr
End Sub

Qs18

试试........

zhangmy66

Qs18 发表于 2024-8-15 15:22
试试..........

各有千秋，多谢帮忙。

zhangcheng6688

学习一下字典，打扰了
Sub test()
arr = Sheets("测试数据").[a1].CurrentRegion
Set d = CreateObject("scripting.dictionary")
ReDim brr(1 To UBound(arr), 1 To UBound(arr, 2))
For i = 2 To UBound(arr)
   s = arr(i, 8) & arr(i, 9) & arr(i, 10)
   If Not d.exists(s) Then
      m = m + 1
      For j = 1 To UBound(arr, 2)
         brr(m, j) = arr(i, j)
      Next
      d(s) = m
   Else
      r = d(s)
      brr(r, 11) = brr(r, 11) + arr(i, 11)
   End If
Next
Sheets("操作结果").[a2].Resize(m, UBound(brr, 2)) = brr
End Sub