SUMIF(A$1:A2,D2,C$1:C2)公式--求同等功能的VBA代码

quqiyuan

jerry3770 发表于 2024-5-4 21:38
我的错  扣错了美元符号@蓝桥老师。您的代码最快中！！谢谢

一程老鸽

Sub pp()
    Dim i, j, k, arr, brr(), d As New Dictionary
    t = Time
    arr = [a1:d10491]
    ReDim brr(1 To 10491, 1 To 1)
    For i = 2 To UBound(arr)
        d(arr(i, 1)) = d(arr(i, 1)) + arr(i, 3)
        If d.Exists(arr(i, 4)) = True Then
            brr(i, 1) = d(arr(i, 4))
        End If
    Next
    Range("f1").Resize(i, 1) = brr()
   
End Sub

一程老鸽

Sub pp()
    Dim i, j, k, arr, brr(), d As New Dictionary
    t = Time
    arr = [a1:d10491]
    ReDim brr(1 To 10491, 1 To 1)
    For i = 2 To UBound(arr)
        d(arr(i, 1)) = d(arr(i, 1)) + arr(i, 3)
        If d.Exists(arr(i, 4)) = True Then
            brr(i, 1) = d(arr(i, 4))
        End If
    Next
    Range("f1").Resize(i, 1) = brr()
   
End Sub

一程老鸽

Sub O秒()
    Dim i, arr, brr()
    Dim d As Object
    Set d = CreateObject("Scripting.Dictionary")
    arr = [a1:d10491]
    ReDim brr(1 To 10491, 1 To 1)
    For i = 2 To UBound(arr)
        d(arr(i, 1)) = d(arr(i, 1)) + arr(i, 3)
        If d.Exists(arr(i, 4)) = True Then
            brr(i, 1) = d(arr(i, 4))
        End If
    Next
    Range("f1").Resize(i, 1) = brr()
End Sub

jjmysjg

一程老鸽 发表于 2024-5-4 22:06
Sub pp()
    Dim i, j, k, arr, brr(), d As New Dictionary
    t = Time

d As New Dictionary
未定义

一程老鸽

jjmysjg 发表于 2024-5-5 07:04
d As New Dictionary
未定义

改一下吧   

一程老鸽

jjmysjg 发表于 2024-5-5 07:04
d As New Dictionary
未定义

修改一下吧。

Sub O秒()
    Dim i, arr, brr()
    Dim d As Object
    Set d = CreateObject("Scripting.Dictionary")
    arr = [a1:d10491]
    ReDim brr(1 To 10491, 1 To 1)
    For i = 2 To UBound(arr)
        d(arr(i, 1)) = d(arr(i, 1)) + arr(i, 3)
        If d.Exists(arr(i, 4)) = True Then
            brr(i, 1) = d(arr(i, 4))
        End If
    Next
    Range("f1").Resize(i, 1) = brr()
End Sub

一程老鸽

改一下吧
Sub O秒()
    Dim i, arr, brr()
    Dim d As Object
    Set d = CreateObject("Scripting.Dictionary")
    arr = [a1:d10491]
    ReDim brr(1 To 10491, 1 To 1)
    For i = 2 To UBound(arr)
        d(arr(i, 1)) = d(arr(i, 1)) + arr(i, 3)
        If d.Exists(arr(i, 4)) = True Then
            brr(i, 1) = d(arr(i, 4))
        End If
    Next
    Range("f1").Resize(i, 1) = brr()
End Sub

yan4088

Function jia(rng1 As Range, criteria As Variant, rng2 As Range) As Double
    Dim i As Long
    Dim total As Double
    total = 0
   
    For i = 1 To rng1.Rows.Count
        If rng1.Cells(i, 1) = criteria Then
            total = total + rng2.Cells(i, 1).Value
        End If
    Next i
   
    jia = total
End Function

自定义一个 jia

swl4561255

没用字典。

1. Sub 按钮2_Click()
   
2. arr = Range("A1").CurrentRegion
   
3. Dim brr()
   
4. For i = 2 To UBound(arr)
   
5.     s = 0
   
6.     m = m + 1
   
7.     ReDim Preserve brr(1 To m)
   
8.     For j = 2 To i
   
9.         If arr(i, 1) = arr(j, 4) Then
   
10.             s = s + arr(j, 3)
    
11.         End If
    
12.     Next
    
13.     brr(m) = s
    
14. Next
    
15. [F2].Resize(m, 1) = Application.Transpose(brr)
    
16. End Sub
    

复制代码