求助如何如何比对差异

月落天涯

劳烦各位大神帮忙，公司时不时有大订单装箱发货，但是发货周期很长，装箱断断续续，这样就需要在每次装箱后统计一下订单还有多少货没装，希望达到的效果是：在差异统计表M2单元格录入订单号并点击按钮后，该订单号装箱数量低于订单数量的，自动筛选并显示差异数量，订单数量来源于订单明细，装箱数量来源于装箱明细，需要强调的是，单一物料往往要多次装箱，才能达到订单数量，因此要累计多次装箱后的数量，比对订单数量，才能得出差异数。差异数=订单数量-装箱数量。有鲜花，谢谢各位大神。表中已经模拟了一个订单的情况。

ykcbf1100

感觉这个求助帖子已经发过了吧，还没解决？

liulang0808

楼主附件模拟的结果跟实际一致吗

liulang0808

Sub ykcbf20240331()
    Set d = CreateObject("scripting.dictionary")
    str1 = [m2].Value
    If Len(str1) = 0 Then
        MsgBox "订单号不能为空"
        Exit Sub
    End If
    arr = Sheets("订单明细").UsedRange
    ReDim brr(1 To UBound(arr), 1 To 8)
    Application.ScreenUpdating = False
    r = Sheets("差异统计").Cells(Rows.Count, 1).End(3).Row
    Sheets("差异统计").Rows("4:" & r + 1).ClearContents
    r = 0
    For j = 1 To UBound(arr)
        If arr(j, 2) = str1 Then
            str2 = arr(j, 2) & arr(j, 3) & arr(j, 4) & arr(j, 5)
            If Not d.exists(str2) Then
                r = r + 1
                d(str2) = r
                brr(r, 1) = r
                brr(r, 2) = arr(j, 2)
                brr(r, 3) = arr(j, 3)
                brr(r, 4) = arr(j, 4)
                brr(r, 5) = arr(j, 5)
                brr(r, 6) = arr(j, 6)
            Else
                rx = d(str2)
                brr(rx, 6) = brr(rx, 6) + arr(j, 6)
            End If
        End If
    Next j
    arr = Sheets("装箱明细").UsedRange
    For j = 1 To UBound(arr)
        If arr(j, 2) = str1 Then
            str2 = arr(j, 2) & arr(j, 3) & arr(j, 4) & arr(j, 5)
            If Not d.exists(str2) Then
                r = r + 1
                d(str2) = r
                brr(r, 1) = r
                brr(r, 2) = arr(j, 2)
                brr(r, 3) = arr(j, 3)
                brr(r, 4) = arr(j, 4)
                brr(r, 5) = arr(j, 5)
                brr(r, 7) = arr(j, 6)
                brr(r, 8) = brr(r, 6) - arr(j, 6)
            Else
                rx = d(str2)
                brr(rx, 7) = arr(j, 6) + brr(rx, 7)
                brr(rx, 8) = brr(rx, 6) - brr(rx, 7)
            End If
        End If
    Next j
    Sheets("差异统计").[a4].Resize(r, UBound(brr, 2)) = brr
    Application.ScreenUpdating = True
End Sub

liulang0808

模拟结果供参考。。。。。。

ykcbf1100

附件供参考。。。

ykcbf1100

参与一下。。。

1. Sub ykcbf()  '//2024.4.8
   
2.     Set d = CreateObject("Scripting.Dictionary")
   
3.     Set sh = ThisWorkbook.Sheets("差异统计")
   
4.     dd = sh.[m2].Value
   
5.     With Sheets("装箱明细")
   
6.         r = .Cells(Rows.Count, 1).End(3).Row
   
7.         arr = .[a1].Resize(r, 6)
   
8.     End With
   
9.     For i = 4 To UBound(arr)
   
10.         s = arr(i, 2) & "|" & arr(i, 3) & "|" & arr(i, 4)
    
11.         d(s) = d(s) + arr(i, 6)
    
12.     Next
    
13.     With Sheets("订单明细")
    
14.         r = .Cells(Rows.Count, 1).End(3).Row
    
15.         arr = .[a1].Resize(r, 6)
    
16.     End With
    
17.     ReDim brr(1 To UBound(arr), 1 To 8)
    
18.     For i = 4 To UBound(arr)
    
19.         If arr(i, 2) = dd Then
    
20.             m = m + 1
    
21.             brr(m, 1) = m
    
22.             For j = 2 To 6
    
23.                 brr(m, j) = arr(i, j)
    
24.             Next
    
25.             brr(m, 7) = d(arr(i, 2) & "|" & arr(i, 3) & "|" & arr(i, 4))
    
26.             brr(m, 8) = brr(m, 6) - brr(m, 7)
    
27.         End If
    
28.     Next
    
29.     On Error Resume Next
    
30.     With sh
    
31.         .[a4:m10000] = ""
    
32.         .[a4].Resize(m, 8) = brr
    
33.     End With
    
34.     Set d = Nothing
    
35.     MsgBox "OK！"
    
36. End Sub
    

复制代码

月落天涯

ykcbf1100 发表于 2024-4-8 07:45
感觉这个求助帖子已经发过了吧，还没解决？

上次的问题已经解决，但这次不一样