多条件数据统计

wyl0205

目前有一客户，需要每月按条件汇总相应的数据，并计算出结果，目前已用公式实现，但是数据量太大，公式计算太费时间，因此向大家求助，盼解决，谢谢大家！
订单明细工作表是原始数据，计算数据工作表是想要的结果，样品类工作表是用来划分小样的，通过关键字判断是否是小样，如果是则按小样计算，如果不是则按正品计算。
最终按照公式计算出应收费用。
注：（此图为了方便解释，把关键字放到了计算数据表里面，实际工作中不需要，从样品类工作表中取关键字即可。因为关键字可能随时在变。）

笨鸟飞不高

Sub AwTest()
    Dim i%, j%, k%, m%, c%, arr, tempAr, d As Object
    Set d = CreateObject("Scripting.Dictionary")
    With Sheets("样品类")
        tempAr = .Range(.Cells(2, 1), .Cells(.Rows.Count, 1).End(3))
    End With
    With Sheets("订单明细")
        arr = .[a1].CurrentRegion
        ReDim brr(1 To 1000, 1 To 4)
        For i = 2 To UBound(arr)
            c = 0
            For j = 1 To UBound(tempAr)
                If InStr(arr(i, 13), tempAr(j, 1)) Then
                    c = 4: Exit For
                Else
                    c = 3
                End If
            Next
            If c = 3 Then
                If Not d.exists(CStr(arr(i, 4))) Then
                    k = k + 1
                    d(CStr(arr(i, 4))) = k
                    brr(k, 1) = arr(i, 4)
                    brr(k, 2) = 1
                    brr(k, 3) = arr(i, 17)
                Else
                    m = d(CStr(arr(i, 4)))
                    brr(m, 2) = brr(m, 2) + 1
                    brr(m, 3) = brr(m, 3) + arr(i, 17)
                End If
            ElseIf c = 4 Then
                If Not d.exists(CStr(arr(i, 4))) Then
                    k = k + 1
                    d(CStr(arr(i, 4))) = k
                    brr(k, 1) = arr(i, 4)
                    brr(k, c) = 1
                Else
                    m = d(CStr(arr(i, 4)))
                    brr(m, c) = brr(m, c) + 1
                End If
            End If
        Next
    End With
    With Sheets("计算数据")
        .[a1].CurrentRegion.Offset(1).Resize(.[a1].CurrentRegion.Rows.Count, 4) = ""
        .[a2].Resize(k, 4) = brr
    End With
End Sub

凑一个！！！！

wyl0205

笨鸟飞不高 发表于 2020-5-31 08:18
Sub AwTest()
    Dim i%, j%, k%, m%, c%, arr, tempAr, d As Object
    Set d = CreateObject("Script ...

还得麻烦您看下，谢谢。
数据量太大，37000行，执行后提示溢出。
点击调试看到下图

microyip

wyl0205 发表于 2020-5-31 11:03
还得麻烦您看下，谢谢。
数据量太大，37000行，执行后提示溢出。
点击调试看到下图

把dim那里的整数型变量改为Double型就不会错了

笨鸟飞不高

演示数据.rar (21.81 KB, 下载次数: 5)

2020-5-31 11:32 上传

点击文件名下载附件

笨鸟飞不高

wyl0205 发表于 2020-5-31 11:03
还得麻烦您看下，谢谢。
数据量太大，37000行，执行后提示溢出。
点击调试看到下图

Dim i%, 改 i&

wyl0205

microyip 发表于 2020-5-31 11:31
把dim那里的整数型变量改为Double型就不会错了

请问怎么修改呢？

wyl0205

笨鸟飞不高 发表于 2020-5-31 11:32

这样还是会报溢出的

笨鸟飞不高

Sub AwTest()
    Dim i&, j%, k%, m%, c%, arr, tempAr, d As Object
    Set d = CreateObject("Scripting.Dictionary")
    With Sheets("样品类")
        tempAr = .Range(.Cells(2, 1), .Cells(.Rows.Count, 1).End(3))
    End With
    With Sheets("订单明细")
        arr = .[a1].CurrentRegion
        ReDim brr(1 To 1000, 1 To 4)
        For i = 2 To UBound(arr)
            c = 0
            For j = 1 To UBound(tempAr)
                If InStr(arr(i, 13), tempAr(j, 1)) Then
                    c = 4: Exit For
                Else
                    c = 3
                End If
            Next
            If c = 3 Then
                If Not d.exists(CStr(arr(i, 4))) Then
                    k = k + 1
                    d(CStr(arr(i, 4))) = k
                    brr(k, 1) = arr(i, 4)
                    brr(k, 2) = 1
                    brr(k, 3) = arr(i, 17)
                Else
                    m = d(CStr(arr(i, 4)))
                    brr(m, 2) = brr(m, 2) + 1
                    brr(m, 3) = brr(m, 3) + arr(i, 17)
                End If
            ElseIf c = 4 Then
                If Not d.exists(CStr(arr(i, 4))) Then
                    k = k + 1
                    d(CStr(arr(i, 4))) = k
                    brr(k, 1) = arr(i, 4)
                    brr(k, c) = 1
                Else
                    m = d(CStr(arr(i, 4)))
                    brr(m, c) = brr(m, c) + 1
                End If
            End If
        Next
    End With
    With Sheets("计算数据")
        .[a1].CurrentRegion.Offset(1).Resize(.[a1].CurrentRegion.Rows.Count, 4) = ""
        .[a2].Resize(k, 4) = brr
    End With
End Sub

笨鸟飞不高

wyl0205 发表于 2020-5-31 11:42
这样还是会报溢出的

改成 i& 这样了吗？？