如何用VBA剔除列表中的重复项及求和

mai51

问题如下：

准提部林

將下面的"....."都刪去
Sub TEST_A1()
Dim Arr, xD, i&, j%, T1$, T2$, N&, R&
Set xD = CreateObject("Scripting.Dictionary")
Arr = Range([D1], [A65536].End(3)): N = 1
For i = 2 To UBound(Arr)
    T1 = Arr(i, 1) & "|" & Arr(i, 2) & "|" & Arr(i, 3)
    T2 = T1 & "|" & Arr(i, 4)
    xD(T2) = xD(T2) + 1: If xD(T2) > 1 Then GoTo i01
    R = xD(T1)
    If R > 0 Then Arr(R, 4) = Arr(R, 4) + Arr(i, 4): GoTo i01
    N = N + 1: R = N: xD(T1) = N
    For j = 1 To 4: Arr(R, j) = Arr(i, j): Next
i01: Next i
With [J1].Resize(N, 4)
     .Value = Arr
     For j = 3 To 1 Step -1
        .Sort Key1:=.Item(j), Order1:=xlAscending, Header:=xlYes
     Next j
End With
End Sub

cui26896

Sub test()
Dim arr, brr, d, d2, i%, j%, j2%, k, k2, s
  Set d = CreateObject("Scripting.Dictionary")
  Set d2 = CreateObject("Scripting.Dictionary")
  arr = Sheets(1).Range("a1:d" & Sheets(1).UsedRange.Rows.Count)
  ReDim brr(1 To UBound(arr), 1 To UBound(arr, 2))
  For i = 2 To UBound(arr)
    s = vbNullString
    For j = 1 To UBound(arr, 2)
      If j < UBound(arr, 2) Then
        s = s & arr(i, j) & "|"
        Else
          s = s & arr(i, j)
      End If
    Next
      If arr(i, 1) <> "……" And Not d.exists(s) Then
        k = k + 1
        d(s) = k
        For j = 1 To UBound(arr, 2)
          brr(d(s), j) = arr(i, j)
        Next
      End If
  Next
    ReDim arr(1 To k, 1 To UBound(brr, 2))
    For i = 1 To k
      s = vbNullString
      For j = 1 To UBound(brr, 2)
        If j < UBound(brr, 2) - 1 Then
          s = s & brr(i, j) & "|"
          Else
            s = s & brr(i, j)
        End If
      Next
        If d2.exists(s) = False Then
          k2 = k2 + 1
          d2(s) = k2
          For j2 = 1 To UBound(brr, 2)
            arr(d2(s), j2) = brr(i, j2)
          Next
            Else
              arr(d2(s), 4) = arr(d2(s), 4) + brr(i, 4)
        End If
    Next
  With Sheets(1)
    .Range("o2").Resize(k2+1, UBound(arr, 2)) = arr
    .Range("o2:r" & k2+1).Sort key1:=.Range("q2"), order1:=xlAscending, Header:=xlNo
    .Range("o2:r" & k2+1).Sort key1:=.Range("p2"), order1:=xlAscending, Header:=xlNo
    .Range("o2:r" & k2+1).Sort key1:=.Range("o2"), order1:=xlAscending, Header:=xlNo
  End With
End Sub

cui26896

要审核，先发附件，请参考
如何用VBA剔除重复项及求和.zip (18.86 KB, 下载次数: 50)

2020-10-17 15:18 上传

点击文件名下载附件

mai51

cui26896 发表于 2020-10-17 14:25
要审核，先发附件，请参考

老师，这结果怎么不对呀？见下图。

cui26896

mai51 发表于 2020-10-17 15:03
老师，这结果怎么不对呀？见下图。

排序漏了最后一行，重新上传了附件，请下载新的附近件。

无敌小猪猪

用sql会不会简单点？

renkangjizhen

第一、二部字典可一次搞定，第三四部排序搞定

mai51

无敌小猪猪 发表于 2020-10-17 15:20
用sql会不会简单点？

这要外部链接，还是用VBA吧，处理时间应该不会快多少

mai51

cui26896 发表于 2020-10-17 15:19
排序漏了最后一行，重新上传了附件，请下载新的附近件。

老师，有个小问题帮忙追加一下，就是D列求和结果四舍五入只保留整数位，不要小数位了。我不太懂编码，劳烦老师帮忙修改一下。