求物品在指定时间之后的指定次数之和

hy397556

字典汇总指定次数之和.rar (12.17 KB, 下载次数: 9)

2024-11-13 09:40 上传

点击文件名下载附件

求助各位老师：时间A列，物品B列，数量C列。根据列出的物品，求该物品在指定时间后，指定的次数之和。用字典与数组解决，谢谢。

loirol

ykcbf1100

附件供参考。。。

ykcbf1100

参与一下。。。

1. Sub ykcbf()   '//2024.11.13
   
2.     Application.ScreenUpdating = False
   
3.     Set d = CreateObject("Scripting.Dictionary")
   
4.     p = ThisWorkbook.Path & ""
   
5.     With Sheets("Sheet1")
   
6.         r = .Cells(Rows.Count, 1).End(3).Row
   
7.         arr = .[a1].Resize(r, 3)
   
8.         rq = .[f1].Value
   
9.         num = 2
   
10.         For i = 2 To UBound(arr)
    
11.             If arr(i, 1) > rq Then
    
12.                 s = arr(i, 2)
    
13.                 If Not d.exists(s) Then Set d(s) = CreateObject("Scripting.Dictionary")
    
14.                 d(s)(arr(i, 1)) = arr(i, 3)
    
15.             End If
    
16.         Next
    
17.         ReDim brr(1 To d.Count, 1 To 2)
    
18.         For Each k In d.keys
    
19.             If d(k).Count > num-1 Then
    
20.                 m = m + 1
    
21.                 brr(m, 1) = k
    
22.                 n = 0
    
23.                 For Each kk In d(k).keys
    
24.                     n = n + 1
    
25.                     brr(m, 2) = brr(m, 2) + d(k)(kk)
    
26.                     If n >= num Then Exit For
    
27.                 Next
    
28.             End If
    
29.         Next
    
30.         .[f4].Resize(m, 2) = brr
    
31.     End With
    
32.     Set d = Nothing
    
33.     Application.ScreenUpdating = True
    
34.     MsgBox "OK！"
    
35. End Sub
    
36. 
    

复制代码

ykcbf1100

。。。。。。。。。

Qs18

1. Sub qs()
   
2. Dim arr, i, dic
   
3. Set dic = CreateObject("scripting.dictionary")
   
4. t = CDate([f1].Value)
   
5. arr = Sheet1.Range("a1").CurrentRegion.Value
   
6.     For i = 2 To UBound(arr)
   
7.         s = arr(i, 2)
   
8.         If CDate(arr(i, 1)) > t Then
   
9.             If Not dic.exists(arr(i, 2)) Then
   
10.                 dic(arr(i, 2)) = arr(i, 3)
    
11.             Else
    
12.                 dic(arr(i, 2)) = dic(arr(i, 2)) + arr(i, 3)
    
13.             End If
    
14.         End If
    
15.     Next i
    
16. Sheet1.Range("f4").Resize(dic.Count, 1) = Application.WorksheetFunction.Transpose(dic.keys)
    
17. Sheet1.Range("g4").Resize(dic.Count, 1) = Application.WorksheetFunction.Transpose(dic.items)
    
18. End Sub

复制代码

yanglinzi

yanglinzi

出现次数按原始表顺序计算

gwjkkkkk

Option Explicit
Sub TEST2()
    Dim ar, br, i&, j&, n&, r&, dte As Date, iMax&
   
    Application.ScreenUpdating = False
   
    dte = [F1].Value: iMax = [G1].Value
    r = Cells(Rows.Count, "f").End(xlUp).Row
    ar = Range("F4:G" & r).Value
    br = [A1].CurrentRegion.Value
   
    For i = 1 To UBound(ar)
        ar(i, 2) = Empty: n = 0
        For j = 2 To UBound(br)
            If br(j, 1) > dte And br(j, 2) = ar(i, 1) Then
                n = n + 1
                If n > iMax Then Exit For
                ar(i, 2) = ar(i, 2) + br(j, 3)
            End If
        Next j
    Next i
   
    [I4].Resize(UBound(ar), 2) = ar
    Application.ScreenUpdating = True
    Beep
End Sub

gwjkkkkk

参与一下。。。