VBA去重后求和

wb5992

对A列去重，B\C\D......列分别求和
最好用字典，数据量较大，谢谢

一把小刀闯天下

Option Explicit

Sub test()
  Dim arr, i, j, m, sum
  arr = [c2].CurrentRegion.Offset(1).Resize(, 4).Value
  ReDim sum(UBound(arr, 2))
  Call qsort(arr, 1, UBound(arr, 1) - 1, 1, UBound(arr, 2), 1)
  For i = 1 To UBound(arr, 1) - 1
    For j = 2 To UBound(arr, 2)
      sum(j) = sum(j) + arr(i, j)
    Next
    If arr(i, 1) <> arr(i + 1, 1) Then
      m = m + 1: arr(m, 1) = arr(i, 1)
      For j = 2 To UBound(arr, 2)
        arr(m, j) = sum(j): sum(j) = 0
      Next
    End If
  Next
  [h3].Resize(m, UBound(arr, 2)) = arr
End Sub

Sub qsort(arr, first, last, left, right, key)
  Dim i As Long, j As Long, k As Long, x, t
  i = first: j = last: x = arr((first + last) \ 2, key)
  While i <= j
    While arr(i, key) < x: i = i + 1: Wend
    While x < arr(j, key): j = j - 1: Wend
    If i <= j Then
      For k = left To right
        t = arr(i, k): arr(i, k) = arr(j, k): arr(j, k) = t
      Next
      i = i + 1: j = j - 1
    End If
  Wend
  If first < j Then qsort arr, first, j, left, right, key
  If i < last Then qsort arr, i, last, left, right, key
End Sub

opel-wong

字典，数组的典型案例，
随手写了一段，代码如下，供参考：

于箱长

我也整一个，练练手

一把小刀闯天下

Option Explicit

Sub test()
  Dim arr, i, j, m, dic
  Set dic = CreateObject("scripting.dictionary")
  arr = [c2].CurrentRegion.Offset(1).Resize(, 4).Value
  For i = 1 To UBound(arr, 1) - 1
    If dic.exists(arr(i, 1)) Then
      For j = 2 To UBound(arr, 2)
        arr(dic(arr(i, 1)), j) = arr(dic(arr(i, 1)), j) + arr(i, j)
      Next
    Else
      m = m + 1: dic(arr(i, 1)) = i
      For j = 1 To UBound(arr, 2)
        arr(m, j) = arr(i, j)
      Next
    End If
  Next
  [h3].Resize(m, UBound(arr, 2)) = arr
End Sub

opel-wong

一把小刀闯天下 发表于 2021-4-1 21:17
Option Explicit

Sub test()

先对第一列进行排序，然后双循环比对去重，累加数据
学习了！

一把小刀闯天下

opel-wong 发表于 2021-4-1 21:31
先对第一列进行排序，然后双循环比对去重，累加数据
学习了！

是的，当数据有序时很多时候问题会变得简单了，，，

opel-wong

一把小刀闯天下 发表于 2021-4-1 21:41
是的，当数据有序时很多时候问题会变得简单了，，，

我用10万数据进行测试两种方法的效率，
用时差不多，但是，排序后输出的数据，看起来要直观一些，

   


压缩后附件超过2MB，无法上传，，

opel-wong

于箱长 发表于 2021-4-1 21:25
我也整一个，练练手

这样循环写入单元格，如果数据量大的话，速度很慢的，
可以考虑数组一次性写入。

于箱长

opel-wong 发表于 2021-4-1 22:17
这样循环写入单元格，如果数据量大的话，速度很慢的，
可以考虑数组一次性写入。

好的，谢谢