求助一个问题

ryoryo66

E列如果出现重复的 菜名，就把那重复的几个单元格对应的L列里的数量相加起来，放在第1个行内的单元格里，再把其它的重复行删除。

比如说，如图 白汤鱼头 这样的情况。  L列的数量相加后，显示在第1个重复名称所对应的L列单元格内，并删除其它的重复项。

chxw68

详见附件。

Qs18

1. Sub qs()
   
2.     Dim arr, i, dic As Object
   
3.     Set dic = CreateObject("scripting.dictionary")
   
4.     With Sheet2
   
5.         r = .Range("a:a").Find("合计").Row - 1
   
6.         arr = .Range("a5").Resize(r - 4, 17).Value
   
7.         ReDim brr(1 To UBound(arr), 1 To UBound(arr, 2))
   
8.         For i = 1 To UBound(arr)
   
9.             s = arr(i, 5)
   
10.             If Not dic.exists(s) Then
    
11.                 m = m + 1
    
12.                 dic(s) = m
    
13.                 brr(m, 1) = arr(i, 1)
    
14.                 brr(m, 4) = arr(i, 4)
    
15.                 brr(m, 5) = arr(i, 5)
    
16.                 brr(m, 12) = arr(i, 12)
    
17.             Else
    
18.                 rw = dic(s)
    
19.                 brr(rw, 12) = brr(rw, 12) + arr(i, 12)
    
20.             End If
    
21.         Next
    
22.         Sheet1.Range("a5").Resize(m, UBound(arr, 2)) = brr
    
23.     End With
    
24. End Sub
    

复制代码

Qs18

试试。。。。。。。。。。

Qs18

试试。。。。。。。。。。。

yanglinzi

1. Sub 删除重复()
   
2. Dim arr, brr, i, j, k, r, d
   
3. Set d = CreateObject("scripting.dictionary")
   
4. With Sheet3
   
5.     r = .Cells(Rows.Count, 4).End(xlUp).Row
   
6.     c = .Cells(4, Columns.Count).End(xlToLeft).Column
   
7.     arr = .Range("a1").Resize(r, c)
   
8. End With
   
9. ReDim brr(1 To UBound(arr), 1 To c)
   
10. For i = 5 To UBound(arr)
    
11.     sa = arr(i, 5)
    
12.     If Not d.exists(sa) Then
    
13.         n = n + 1
    
14.         For j = 1 To UBound(arr, 2)
    
15.             brr(n, j) = arr(i, j)
    
16.         Next
    
17.         d(sa) = n
    
18.     Else
    
19.         m = d(sa)
    
20.         brr(m, 12) = brr(m, 12) + arr(i, 12)
    
21.     End If
    
22. Next
    
23. Stop
    
24. With Sheet2
    
25.     .Range("a5").Resize(r - 3, c).Clear
    
26.     .[a5].Resize(n, c) = brr
    
27.     .[a5].Resize(n, c).Borders.LineStyle = 1
    
28. End With
    
29. End Sub

复制代码

yanglinzi

参与一下。。

usedrange

参与一下，单击“点我”按钮

usedrange

1. Sub tt()
   
2.     Dim ar, br, j%, i%, dic, k, t, r%
   
3.     Set dic = CreateObject("scripting.dictionary")
   
4.     ar = [a5].CurrentRegion
   
5.     ReDim br(1 To UBound(ar) - 4, 1 To UBound(ar, 2))
   
6.     For i = 5 To UBound(ar)
   
7.         dic(ar(i, 1) & "|" & ar(i, 5)) = dic(ar(i, 1) & "|" & ar(i, 5)) + ar(i, 12)
   
8.     Next i
   
9.     r = 1
   
10.     For Each k In dic.keys
    
11.         t = Split(k, "|")
    
12.         br(r, 1) = t(0)
    
13.         br(r, 5) = t(1)
    
14.         br(r, 12) = dic(k)
    
15.         r = r + 1
    
16.     Next k
    
17.     Range("a1:q4").Copy [s1]
    
18.     [s5].Resize(UBound(br), UBound(br, 2)) = br
    
19.     Set dic = Nothing
    
20. End Sub

复制代码

扇扇扇