怎样快速去重累计指定列数据？谢谢！

ztd123

怎样快速去重累计指定列数据？谢谢！ 累计去重.rar (14.36 KB, 下载次数: 18)

2022-8-20 10:00 上传

点击文件名下载附件

liulang0808

Private Sub CommandButton1_Click()
    Set d = CreateObject("scripting.dictionary")
    Set Rng = Nothing
    Application.ScreenUpdating = False
    For j = 2 To Cells(Rows.Count, 4).End(3).Row
        If d.exists(Cells(j, 4) & "") Then
            x = d(Cells(j, 4) & "")
            Cells(x, "p") = Cells(x, "p") + Cells(j, "p")
            If Rng Is Nothing Then
                Set Rng = Cells(j, 1)
            Else
                Set Rng = Union(Rng, Cells(j, 1))
            End If
        Else
            d(Cells(j, 4) & "") = j
        End If
    Next j
    If Not Rng Is Nothing Then Rng.EntireRow.Delete
    Application.ScreenUpdating = True
End Sub

liulang0808

附件内容供参考。。。。。

chxw68

1. Sub test()
   
2.   Dim r%, i%
   
3.   Dim arr, brr
   
4.   Dim d As Object
   
5.   Dim rng As Range
   
6.   Set d = CreateObject("scripting.dictionary")
   
7.   With Worksheets("sheet1")
   
8.     r = .Cells(.Rows.Count, 1).End(xlUp).Row
   
9.     c = .Cells(1, .Columns.Count).End(xlToLeft).Column
   
10.     arr = .Range("a1").Resize(r, c)
    
11.     Set rng = .Rows(r + 1)
    
12.     For i = 2 To UBound(arr)
    
13.       If Not d.exists(arr(i, 4)) Then
    
14.         d(arr(i, 4)) = i
    
15.       Else
    
16.         m = d(arr(i, 4))
    
17.         arr(m, 16) = arr(m, 16) + arr(i, 16)
    
18.         Set rng = Union(rng, .Rows(i))
    
19.       End If
    
20.     Next
    
21.     .Range("a1").Resize(UBound(arr), UBound(arr, 2)) = arr
    
22.     rng.Delete
    
23.   End With
    
24. End Sub
    

复制代码

chxw68

练练练手。

ztd123

感谢楼上两位老师，再次感谢！

准提部林

Sub TEST_A1()
Dim Arr, Brr, xD, T$, i&, R&
Set xD = CreateObject("scripting.dictionary")
Arr = Range([P1], Cells(Rows.Count, 1).End(3))
ReDim Brr(1 To UBound(Arr), 0)
For i = 2 To UBound(Arr)
    T = Arr(i, 4): R = xD(T)
    If xD(T) = 0 Then R = i - 1: xD(T) = R
    Brr(R, 0) = Brr(R, 0) + Val(Arr(i, 16))
Next i
With [P2].Resize(UBound(Arr))
     .Value = Brr
     .SpecialCells(xlCellTypeBlanks).EntireRow.Delete
End With
End Sub

ztd123

chxw68 发表于 2022-8-20 10:17
练练练手。

老师您好，数据（行）多了 提示溢出 r = .Cells(.Rows.Count, 1).End(xlUp).Row能否帮忙改一下，谢谢您！

wowo000

ztd123 发表于 2022-12-8 09:20
老师您好，数据（行）多了 提示溢出 r = .Cells(.Rows.Count, 1).End(xlUp).Row能否帮忙改一下，谢谢您！

楼主：把chxw68老师的代码第二行中的百分号改成&试试。

ztd123

wowo000 发表于 2022-12-8 12:46
楼主：把chxw68老师的代码第二行中的百分号改成&试试。

谢谢您 好了