[已解决]多条件汇总且取最后一个日期

su77

各位大神：                 附表中需按【订单】+【物料编码】来汇总对应的数量总数，且取最后的【入库日期】，如【入库明细表】里：订单CGDD21120792+物料编码0415000145有三次入库，入库数量为15，对应的最后入库日期为2022/03/12，将该结果写入【分析表】对应的列。  
        以上没有找到符合要求的，故向各位请教。

最佳答案

月排行榜 / 总排行榜

sam-wang

2022-6-6 12:11

請測試看看，謝謝

Sub test()
Dim Arr, Brr(), xD, T$, i&, j%
Set xD = CreateObject("Scripting.Dictionary")
With Sheets(1)
    Arr = .[a1].CurrentRegion
    ReDim Brr(1 To UBound(Arr), 1 To 6)
    For i = 2 To UBound(Arr)
        T = Arr(i, 4) & "|" & Arr(i, 5)
        If xD.Exists(T) Then
            n1 = xD(T): Brr(n1, 5) = Brr(n1, 5) + Arr(i, 9)
            If Brr(n1, 6) < Arr(i, 10) Then Brr(n1, 6) = Arr(i, 10)
        Else
            n = n + 1: xD(T) = n: Brr(n, 5) = Arr(i, 9)
            For j = 1 To 4: Brr(n, j) = Arr(i, j + 3): Next
            Brr(n, 6) = Arr(i, 10)
        End If
    Next
End With
If n > 0 Then Sheets(2).[a2].Resize(n, 6) = Brr
End Sub

跳转到最佳答案楼层

hasyh2008

Sub 字典法汇总()
  On Error Resume Next
  Dim Arr, Brr(), Rc%, K%, Dic, Str$
  Set Dic = CreateObject("scripting.dictionary")
  Arr = Sheets("入库明细").Range("A1").CurrentRegion
  Sheets("分析表").Range("A1").CurrentRegion = ""
  K = 0
  For Rc = 1 To UBound(Arr)
    Str = Arr(Rc, 4) & Arr(Rc, 5)       '& Arr(Rc, 6) & Arr(Rc, 7)
    If Dic.Exists(Str) Then
      Brr(5, Dic(Str)) = Brr(5, Dic(Str)) + Arr(Rc, 9)
      If Brr(6, Dic(Str)) < Arr(Rc, 10) Then Brr(6, Dic(Str)) = Arr(Rc, 10)
    Else
      K = K + 1
      Dic(Str) = K
      ReDim Preserve Brr(1 To 6, 1 To K)
      Brr(1, K) = Arr(Rc, 4): Brr(2, K) = Arr(Rc, 5)
      Brr(3, K) = Arr(Rc, 6): Brr(4, K) = Arr(Rc, 7)
      Brr(5, K) = Arr(Rc, 9): Brr(6, K) = Arr(Rc, 10)
    End If
  Next Rc
  Sheets("分析表").Range("A1").Resize(K, 6) = Application.Transpose(Brr)
  Sheets("分析表").Range("F1") = "最后入库日期"
  Set Dic = Nothing
End Sub

sam-wang

請測試看看，謝謝

Sub test()
Dim Arr, Brr(), xD, T$, i&, j%
Set xD = CreateObject("Scripting.Dictionary")
With Sheets(1)
    Arr = .[a1].CurrentRegion
    ReDim Brr(1 To UBound(Arr), 1 To 6)
    For i = 2 To UBound(Arr)
        T = Arr(i, 4) & "|" & Arr(i, 5)
        If xD.Exists(T) Then
            n1 = xD(T): Brr(n1, 5) = Brr(n1, 5) + Arr(i, 9)
            If Brr(n1, 6) < Arr(i, 10) Then Brr(n1, 6) = Arr(i, 10)
        Else
            n = n + 1: xD(T) = n: Brr(n, 5) = Arr(i, 9)
            For j = 1 To 4: Brr(n, j) = Arr(i, j + 3): Next
            Brr(n, 6) = Arr(i, 10)
        End If
    Next
End With
If n > 0 Then Sheets(2).[a2].Resize(n, 6) = Brr
End Sub

风林火山

1. Sub test()
   
2.     Dim arr, brr(1 To 1000, 1 To 6), k As Integer, i As Integer, n As Integer
   
3.     Dim d
   
4.    
   
5.     Set d = CreateObject("scripting.dictionary")
   
6.     arr = Sheets("入库明细").Range("A1").CurrentRegion
   
7.     For k = 2 To UBound(arr)
   
8.         If Not d.exists(arr(k, 4) & arr(k, 5)) Then
   
9.             i = i + 1
   
10.             d(arr(k, 4) & arr(k, 5)) = i
    
11.             brr(i, 1) = arr(k, 4): brr(i, 2) = arr(k, 5)
    
12.             brr(i, 3) = arr(k, 6): brr(i, 4) = arr(k, 7)
    
13.             brr(i, 5) = arr(k, 9): brr(i, 6) = arr(k, 10)
    
14.         Else
    
15.             n = d(arr(k, 4) & arr(k, 5))
    
16.             brr(n, 5) = brr(n, 5) + arr(k, 9)
    
17.             If arr(k, 10) > brr(n, 6) Then brr(n, 6) = arr(k, 10)
    
18.         End If
    
19.     Next k
    
20.     Sheets("分析表").Range("a1:f1") = Array("订单", "物料编码", "名称", "图号", "入库数量汇总", "最后入库日期")
    
21.     Sheets("分析表").Range("a2:f1000").ClearContents
    
22.     Sheets("分析表").Range("a2").Resize(i, 6) = brr
    
23. End Sub
    

复制代码

su77

sam-wang 发表于 2022-6-6 12:11
請測試看看，謝謝

Sub test()

谢谢，您的代码简单易懂。

su77

风林火山 发表于 2022-6-6 12:43

谢谢您的代码，辛苦了！

su77

hasyh2008 发表于 2022-6-6 12:06
Sub 字典法汇总()
  On Error Resume Next
  Dim Arr, Brr(), Rc%, K%, Dic, Str$

谢谢您的代码，辛苦了！

scnc001

经测试，都可以正常运行