按发料料号匹配库存后，得出最终工单欠数

adm0795

求助：
因工单较多，每天需要从系统导出，重新匹配工单欠数。实际每天有几千个工单要匹配


要求按表中发料料号（H列）的先后顺序匹配库存后得出最终各工单欠数，因为同一个料号O列会显示这个料号对应的工单都有库存。需要按需匹配库存得出最终工单实际欠数.( P列)是按工单欠数匹配的可扣库存，Q列为此工单最终欠数

3190496160

看半天，直接蒙圈

loirol

ykcbf1100

没看明白。不知道最后的数是怎么计算出来的。

adm0795

loirol 发表于 2024-12-19 10:59

不对哦。第三项，扣完前面两项，实际剩余可扣库存只有41呢，工单欠数应为1359，最后二项计算结果也是错的呢，这个料号的库存前面二个工单已经扣了20，只余5个，倒数第二个工单只有5个库存可扣。最后一项实际可用库存是0

adm0795

loirol 发表于 2024-12-19 10:59

不对哦。O列的数据不要变化，只需更新P及Q列的数据。

adm0795

ykcbf1100 发表于 2024-12-19 11:58
没看明白。不知道最后的数是怎么计算出来的。

最后的数量是我手工算出来的，未发数量-可用库存=欠数（如果可用库存大于未发数量，则未扣完的数量继续扣到相同料号的下一个工单上。

adm0795

3190496160 发表于 2024-12-19 10:45
看半天，直接蒙圈

计算原理：未发数量-此料号可用库存=工单欠数（如果此料号的可用库存大于工单未发数量，则未扣完的数量继续扣到相同料号的下一个工单上。

z865593849

求库存

3190496160

Sub 欠料计算()
Dim ar As Variant, cr As Variant
Dim i As Long, r As Long
Dim d As Object
Set d = CreateObject("scripting.dictionary")
Set dc = CreateObject("scripting.dictionary")
With Sheets("sheet1")
    r = .Cells(Rows.Count, 1).End(xlUp).Row
    .Range("p2:q" & r) = Empty
    ar = .Range("a1:q" & r)
    For i = 2 To UBound(ar)
        s = ar(i, 8)
        If s <> "" Then
            If Not d.exists(s) Then Set d(s) = CreateObject("scripting.dictionary")
            d(s)(i) = ""
            dc(s) = ar(i, 15)
        End If
    Next i
    For Each k In d.keys
        sl = dc(k)
        ys = 0: m = 0
        For Each kk In d(k).keys
            m = m + 1
            If m = 1 Then
                If ar(kk, 15) >= ar(kk, 12) Then
                    ar(kk, 16) = ar(kk, 12)
                    ys = sl - ar(kk, 12)
                Else
                    ar(kk, 16) = ar(kk, 15)
                    ys = sl - ar(kk, 15)
                End If
            Else
                If ys >= ar(kk, 12) Then
                    ar(kk, 16) = ar(kk, 12)
                    ys = ys - ar(kk, 12)
                Else
                    If ys > 0 Then
                        ar(kk, 16) = ys
                         ys = ys - ar(kk, 12)
                    Else
                        ar(kk, 16) = 0
                    End If
                End If
            End If
            ar(kk, 17) = ar(kk, 12) - ar(kk, 16)
        Next kk
    Next k
    .Range("a1:q" & r) = ar
End With
Set d = Nothing
MsgBox "ok!"
End Sub