Excel VBA 用字典方法做先进先出法

多年前，一家外包公司帮我司一物业公司做仓库收发存管理软件，我方要求先进先出法，该外包公司称那需要加入批次管理，每次出库选择好批次才能实现先进先出。我以为，这完全是谬论，既然是先进先出，那就已经设定好了规律和逻辑，不需要再指定批次，否则那还叫什么先进先出。最近，闲来无事，用EXCEL编了个小程序，经调试，是可以做到先进先出的。上图：

 备注：出入库按入正出负的原则制订

完整代码：

Public Crr() As Integer, StartingPosition%
Sub FirstInFirstOut()
    Dim Arr, Brr, Drr, i%, TypeCount%, j%, MaxAmount%
    Dim Dic As Object
    Set Dic = CreateObject("scripting.dictionary")
    Arr = [A1].CurrentRegion

    '按字典方法，获取产品种类
    For i = 2 To UBound(Arr)
        If Arr(i, 2) >= 0 Then
        Dic(Arr(i, 1)) = Dic(Arr(i, 1)) + Arr(i, 2)
        End If
    Next
    TypeCount = Dic.Count
    Brr = Dic.Keys
    Drr = Dic.Items
    
    '获取进货的总数量
    MaxAmount = Application.WorksheetFunction.Max(Drr)
    ReDim Crr(1 To TypeCount, 1 To MaxAmount)

    For i = 2 To UBound(Arr)
        'If Arr(i, 2) > 0 Then
        For j = 0 To TypeCount - 1
            If Brr(j) = Arr(i, 1) Then
                If Arr(i, 2) > 0 Then
                '目标Crr，第一维度为j+1,第二维度的数量：cells（i,2)，第二维度的单价：cells(i,3)
                    Call GetStartingPosition(j + 1)
                    Call AddDate(j + 1, Val(Arr(i, 2)), Val(Arr(i, 3)))
                    Exit For
                Else
                    Call DeleteDate(j + 1, Val(Arr(i, 2)), i)
                    Exit For
                End If
            End If
        Next
        'End If
    Next


End Sub
Sub GetStartingPosition(i As Integer)
    For k = 1 To UBound(Crr, 2)
        If Crr(i, k) = Empty Or Crr(i, k) = 0 Then
            StartingPosition = k
            Exit For
        End If
    Next
End Sub
Sub AddDate(i%, j%, k%)
    For x = StartingPosition To StartingPosition + j - 1
        Crr(i, x) = k
    Next
End Sub
Sub DeleteDate(i, j, CellsNumber)
    Dim OutTotalAmount%, Drr() As Integer
    ReDim Drr(1 To UBound(Crr, 2)) As Integer
    For x = 1 To -j
        OutTotalAmount = OutTotalAmount + Crr(i, x)
        Crr(i, x) = Empty
    Next
    Cells(CellsNumber, 4) = -OutTotalAmount
    
    For x = -j + 1 To UBound(Crr, 2)
        Drr(x - -j) = Crr(i, x)
        Crr(i, x) = Empty
    Next
    
    For Temp = 1 To UBound(Drr)
        Crr(i, Temp) = Drr(Temp)
    Next
    
End Sub