数值累加，但是数据达到几千行就运转不出

adai2014

建议用透视表：先把数据源区域变成表结构（选中数据源区域，按 Ctrl+T 即可），然后再基于这个表去做透视表，按某一字段汇总。若数据有更新，刷新即可

bjzzxhzl

这类计算交给Power Pivot，基本都是秒刷。

3190496160

Sub 分类累计()
Application.ScreenUpdating = False
Dim ar As Variant
Dim d As Object
Dim br()
Set d = CreateObject("scripting.dictionary")
With Sheets("原数据")
    r = .Cells(Rows.Count, 1).End(xlUp).Row
    If r < 2 Then MsgBox "原数据为空！": End
    ar = .Range("a1:d" & r)
End With
For i = 2 To UBound(ar)
    If Trim(ar(i, 1)) <> "" Then
        d(Trim(ar(i, 1))) = ""
    End If
Next i
With Sheets("目标输出")
    .[a1].CurrentRegion.Offset(1) = Empty
    For Each k In d.keys
        n = 0
        ReDim br(1 To UBound(ar), 1 To UBound(ar, 2) + 2)
        For i = 2 To UBound(ar)
            If Trim(ar(i, 1)) = k Then
                n = n + 1
                For j = 1 To UBound(ar, 2)
                    br(n, j) = ar(i, j)
                Next j
                If n = 1 Then
                    br(n, 5) = ar(i, 3)
                    br(n, 6) = ar(i, 4)
                Else
                    br(n, 5) = br(n - 1, 5) + ar(i, 3)
                    br(n, 6) = br(n - 1, 6) + ar(i, 4)
                End If
            End If
        Next i
        rs = .Cells(Rows.Count, 1).End(xlUp).Row + 1
        .Cells(rs, 1).Resize(n, UBound(br, 2)) = br
    Next k
End With
Set d = Nothing
Application.ScreenUpdating = True
MsgBox "ok!"
End Sub

3190496160

3190496160

试验.rar (25.29 KB, 下载次数: 4)

2023-4-29 09:29 上传

点击文件名下载附件

3190496160

vba完成的，只是这么几列数据的话，几万行也就是秒速

libo5563

分组，加索引，用table.firstn  尽量减少筛选，别嫌公式写的难看，table.selectrows 不能用，慢在这了，  这种累计，应该是pp 干的活

my0745

libo5563 发表于 2023-4-30 21:29
分组，加索引，用table.firstn  尽量减少筛选，别嫌公式写的难看，table.selectrows 不能用，慢在这了，   ...

在PQ中，你的代码效率很高

Tongbaby2020

3190496160 发表于 2023-4-29 09:30
vba完成的，只是这么几列数据的话，几万行也就是秒速

可以将日期横向吗

Tongbaby2020

libo5563 发表于 2023-4-30 21:29
分组，加索引，用table.firstn  尽量减少筛选，别嫌公式写的难看，table.selectrows 不能用，慢在这了，   ...

这个确实是快，厉害了