二个数组数据量大时运行错误

sc204400

zxsea_7426 发表于 2022-12-18 09:52
修改如下：

精简后如下：

类别统计的金额没统计对全按第一类别的金额填写了

zxsea_7426

sc204400 发表于 2022-12-18 10:55
类别统计的金额没统计对全按第一类别的金额填写了

重新写了一个，






Sub 主营收入月明细4()
    Application.ScreenUpdating = False
    Set d = CreateObject("scripting.dictionary")
    With Sheets("已开发票明细表")
        arr = .Range(.Cells(1, 1), .Cells(Rows.Count, 40).End(3))
    End With
    For j = 2 To UBound(arr)
        If Not d.Exists(arr(j, 1)) Then
            Set d(arr(j, 1)) = CreateObject("scripting.dictionary")
        End If
        d(arr(j, 1))(arr(j, 40)) = d(arr(j, 1))(arr(j, 40)) + arr(j, 23)
    Next j
    ReDim brr(1 To d.Count + 1, 1 To 1)
    For Each Key In d.keys
        N = N + 1: M = 0
        If d(Key).Count + 1 > UBound(brr) Then
            ReDim Preserve brr(1 To d.Count + 1, 1 To d(Key).Count + 1)
        End If
        brr(N + 1, 1) = Key
        For Each key_ In d(Key).keys
            M = M + 1
            If brr(1, M + 1) = "" Then brr(1, M + 1) = key_
            brr(N + 1, M + 1) = d(Key)(key_)
        Next
    Next
    With Sheets("主营收入月明细")
        .[c7].Resize(UBound(brr), UBound(brr, 2)) = brr
        .[c7].CurrentRegion.Borders.LineStyle = xlContinuous
        .[c7] = "月份"
    End With


    Application.ScreenUpdating = True
End Sub

准提部林

Sub TEST_A1()
Dim Arr, xD, M$, T$, MT$, R&, C&, i&, j&
Set xD = CreateObject("scripting.dictionary")
Arr = Range(Sheet1.[an1], Sheet1.Cells(Rows.Count, 1).End(3))
For i = 2 To UBound(Arr)
    M = Arr(i, 1): T = Arr(i, 40): MT = M & "|" & T
    If xD(M) = 0 Then R = R + 1: xD(R & "-r") = M: xD(M) = 1
    If xD(T) = 0 Then C = C + 1: xD(C & "-c") = T: xD(T) = 1
    xD(MT) = xD(MT) + Val(Arr(i, 23))
Next i
ReDim Arr(1 To R + 1, 1 To C + 1)
For i = 1 To R
    M = xD(i & "-r"): Arr(i + 1, 1) = M
    For j = 1 To C
        T = xD(j & "-c"): Arr(1, j + 1) = T
        Arr(i + 1, j + 1) = xD(M & "|" & T)
    Next j
Next i
With Sheet2.[c7].Resize(R + 1, C + 1)
     .Value = Arr
     .Item(1) = "月份"
     .Borders.LineStyle = 1
End With
End Sub

今日123

新人也来参与一下
Sub 汇总3()
Dim arr, brr, n, c, r, d(1)
For i = 0 To 1
    Set d(i) = CreateObject("Scripting.dictionary")
Next i
With Sheets("已开发票明细表")
    r = .Cells(.Rows.Count, 1).End(3).Row
    arr = .Range("a1:an" & r)
End With
n = 1
For i = 2 To UBound(arr)
    If Not d(0).exists(arr(i, 40)) Then
        n = n + 1
        d(0)(arr(i, 40)) = n
    End If
Next i
c = 1 + d(0).Count
For i = 2 To UBound(arr)
    If Not d(1).exists(arr(i, 1)) Then
        ReDim brr(1 To c)
        brr(1) = arr(i, 1)
    Else
        brr = d(1)(arr(i, 1))
    End If
    n = d(0)(arr(i, 40))
    brr(n) = brr(n) + arr(i, 23)
    d(1)(arr(i, 1)) = brr
Next i
With Sheets("主营收入月明细")
    .[a15] = "月份"
    .[b15].Resize(1, d(0).Count) = d(0).keys
    .[a16].Resize(d(1).Count, c) = Application.Rept((d(1).items), 1)
    With .Range("a15").Resize(1 + d(1).Count, c)
      .Borders.LineStyle = xlContinuous
      .HorizontalAlignment = xlCenter
      .VerticalAlignment = xlCenter
    End With
End With
End Sub