VBA去重后求和

于箱长

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

听人劝吃饱饭，数组一次性输出来了

opel-wong

于箱长 发表于 2021-4-2 13:34
听人劝吃饱饭，数组一次性输出来了

用10万+的数据量，将你11楼的代码，与2楼，3楼的代码，
分别测试一下速度，看看效果，

于箱长

opel-wong 发表于 2021-4-2 15:04
用10万+的数据量，将你11楼的代码，与2楼，3楼的代码，
分别测试一下速度，看看效果，

好的，我整一组数据测试一下，谢谢

wb5992

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

Sub test()

您好 去重复没有问题，但是经过比对有1000行重复数据没有相加
不知是什么原因造成的

wb5992

opel-wong 发表于 2021-4-1 21:19
字典，数组的典型案例，
随手写了一段，代码如下，供参考：

麻烦有空帮忙再看一下  5楼的代码去重没问题，但是相加和数据源总数不对，另外你用的什么工具进行代码排序的

准提部林

Sub TEST_A1()
Dim Arr, xD, i&, j%, T$, U&, V&, N&
Set xD = CreateObject("scripting.dictionary")
Arr = Range([F1], Cells(Rows.Count, "c").End(3))
For i = 3 To UBound(Arr)
    T = Arr(i, 1): If T = "" Then GoTo i01
    U = xD(T): V = U
    If U = 0 Then N = N + 1: U = N: xD(T) = U: Arr(U + 2, 1) = T
    For j = 2 To UBound(Arr, 2)
        Arr(U + 2, j) = Val(Arr(i, j)) - Arr(U + 2, j) * (V > 0)
    Next j
i01: Next i
[h1].Resize(N + 2, UBound(Arr, 2)) = Arr
End Sub

opel-wong

wb5992 发表于 2021-4-6 19:38
麻烦有空帮忙再看一下  5楼的代码去重没问题，但是相加和数据源总数不对，另外你用的什么工具进行代码排 ...

你用三楼的代码试试，
如果不行，就把出错的附件上传，

wb5992

opel-wong 发表于 2021-4-6 20:22
你用三楼的代码试试，
如果不行，就把出错的附件上传，

OK了 感谢

20w行 6s

一把小刀闯天下

wb5992 发表于 2021-4-6 15:41
您好 去重复没有问题，但是经过比对有1000行重复数据没有相加
不知是什么原因造成的

'测试了一下没有什么问题，哪一楼的代码？

'14楼附件20W+数据，快排比字典会快点。重复非常非常少字典的优势已经不存在了，，，

Option Explicit

Sub test()
  Dim i, m, arr, filename, t, tm
  filename = ThisWorkbook.Path & "\test.txt"
  If Dir(filename) = vbNullString Then MsgBox filename: Exit Sub
  tm = Timer
  Call doevent(False)
  Open filename For Input As #1
  arr = Split(StrConv(InputB(LOF(1), 1), vbUnicode), vbNewLine)
  Close #1
  ReDim brr(1 To UBound(arr) + 2, 1 To 2)
  For i = 0 To UBound(arr, 1)
    arr(i) = Replace(arr(i), Space(1), vbNullString)
    If InStr(arr(i), vbTab) Then
      t = Split(arr(i), vbTab)
      If UBound(t) <> 1 Then MsgBox arr(i): Call doevent(True): Exit Sub
      m = m + 1
      brr(m, 1) = t(0): brr(m, 2) = Val(t(1))
    End If
  Next
  [g1].Resize(m, 2) = brr
  Debug.Print "源数据：", Timer - tm
  tm = Timer
  Call 排序法(brr, m)
  Debug.Print "排序：", Timer - tm
  tm = Timer
  Call 字典法(brr, m)
  Debug.Print "字典：", Timer - tm
  Call doevent(True)
End Sub

Function 字典法(arr, m)
  Dim i, j, cnt, dic
  Set dic = CreateObject("scripting.dictionary")
  ReDim brr(1 To m, 1 To 2)
  For i = 1 To m
    If dic.exists(arr(i, 1)) Then
      brr(dic(arr(i, 1)), 2) = brr(dic(arr(i, 1)), 2) + arr(i, 2)
    Else
      cnt = cnt + 1: dic(arr(i, 1)) = i
      brr(cnt, 1) = arr(i, 1): brr(cnt, 2) = arr(i, 2)
    End If
  Next
  [d1].Resize(cnt, 2) = brr
End Function

Function 排序法(arr, m)
  Dim i, cnt, sum
  ReDim brr(1 To m, 1 To 2)
  Call qsort(arr, 1, m, 1, 2, 1)
  For i = 1 To m
    sum = sum + arr(i, 2)
    If arr(i, 1) <> arr(i + 1, 1) Then
      cnt = cnt + 1: brr(cnt, 1) = arr(i, 1)
      brr(cnt, 2) = sum: sum = 0
    End If
  Next
  [a1].Resize(cnt, 2) = brr
End Function

Function 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 Function

Function doevent(flag As Boolean)
  With Application
    .DisplayAlerts = flag
    .ScreenUpdating = flag
  End With
End Function

liulang0808

具体结果可以按照需求区域放置