多仓对多仓就近仓调拨求VBA代码

昵称不好起

以优先满足店铺需求为准，求VBA代码

3190496160

Sub 调拨()
Application.ScreenUpdating = False
Dim ar As Variant, br As Variant
Dim cr()
Dim d As Object, dc As Object
Set d = CreateObject("scripting.dictionary")
Set dc = CreateObject("scripting.dictionary")
Set dic = CreateObject("scripting.dictionary")
With Sheets("店铺需求")
    r = .Cells(Rows.Count, 1).End(xlUp).Row
    If r < 3 Then MsgBox "店铺需求为空！": End
    ar = .Range("a2:c" & r)
End With
With Sheets("库存")
    rs = .Cells(Rows.Count, 1).End(xlUp).Row
    If rs < 3 Then MsgBox "库存为空！": End
    br = .Range("a2:g" & rs)
End With
For i = 2 To UBound(br)
    If br(i, 1) <> "" Then
        If Not d.exists(br(i, 1)) Then Set d(br(i, 1)) = CreateObject("scripting.dictionary")
        d(br(i, 1))(i) = ""
    End If
Next i
For j = 2 To UBound(br, 2)
    dc(br(1, j)) = j
Next j
ReDim arr(1 To UBound(ar) * 2, 1 To 4)
For i = 2 To UBound(ar)
    bm = ar(i, 1)
    If bm <> "" Then
        dp = ar(i, 2)
        lh = dc(dp)
        xql = ar(i, 3)
        m = m + 1
        arr(m, 1) = bm
        arr(m, 3) = dp
        n = 0
        ReDim cr(1 To UBound(br), 1 To UBound(br, 2))
        For Each k In d(bm).keys
            n = n + 1
            For j = 1 To UBound(br, 2)
                cr(n, j) = br(k, j)
            Next j
        Next k
        For ii = 1 To n
            For s = ii + 1 To n
                If cr(ii, lh) > cr(s, lh) Then
                    For j = 1 To UBound(cr, 2)
                        kk = cr(ii, j)
                        cr(ii, j) = cr(s, j)
                        cr(s, j) = kk
                    Next j
                End If
            Next s
        Next ii
        zx = cr(1, lh)
        kc = cr(1, 3)
        zf = cr(1, 1) & "|" & cr(1, 2)
        dic(zf) = kc - (xql - dic(zf))
        If dic(zf) >= 0 Then
            arr(m, 2) = cr(1, 2)
            arr(m, 4) = xql
        Else
            arr(m, 2) = cr(1, 2)
            arr(m, 4) = kc
            m = m + 1
            arr(m, 1) = bm
            arr(m, 3) = dp
            arr(m, 2) = cr(2, 2)
            arr(m, 4) = xql - kc
            zf = cr(2, 1) & "|" & cr(2, 2)
            dic(zf) = cr(2, 3) - (xql - dic(zf))
        End If
    End If
Next i
With Sheets("调拨")
    .[a1].CurrentRegion.Offset(2) = Empty
    .[a3].Resize(m, UBound(arr, 2)) = arr
End With
Application.ScreenUpdating = True
MsgBox "ok!"
End Sub

3190496160

多仓对多仓就近调拨.rar (23.78 KB, 下载次数: 18)

2024-6-19 11:00 上传

点击文件名下载附件

3190496160

结果未认真核对，代码仅供参考

昵称不好起

3190496160 发表于 2024-6-19 11:01
结果未认真核对，代码仅供参考

好的，谢谢，我研究一下

413254881

Option Explicit
Sub t()
    Dim arr As Variant, brr As Variant, i As Long, k As Long, 需求量 As Long, 库存_row As Long
    arr = ThisWorkbook.ActiveSheet.Range("A1").CurrentRegion.Value
    brr = ThisWorkbook.ActiveSheet.Range("F1").CurrentRegion.Value
    Dim dic As Object: Set dic = CreateObject("scripting.dictionary")
    dic.Add "A", 4
    dic.Add "B", 5
    dic.Add "C", 6
    dic.Add "D", 7
    Dim crr As Variant: ReDim crr(1 To 10000, 1 To 4)
    k = 1
    For i = 3 To UBound(arr)
        需求量 = arr(i, 3)
        Do While 需求量 > 0
            库存_row = MinRowIndex(brr, dic(arr(i, 2)), arr(i, 1))
            crr(k, 1) = arr(i, 1)
            crr(k, 2) = brr(库存_row, 2)
            crr(k, 3) = arr(i, 2)
            crr(k, 4) = IIf(需求量 <= brr(库存_row, 3), 需求量, brr(库存_row, 3))
            brr(库存_row, 3) = brr(库存_row, 3) - crr(k, 4)
            需求量 = 需求量 - crr(k, 4)
            k = k + 1
        Loop
    Next
    ThisWorkbook.ActiveSheet.Range("N3").Resize(UBound(crr, 1), UBound(crr, 2)).Value = crr
End Sub
Function MinRowIndex(ByRef arr As Variant, ByVal colIndex As Long, ByVal num As Long) As Variant
    Dim i As Long, firstMatch As Boolean, minValue As Long, foundRow As Long
    For i = LBound(arr) To UBound(arr)
        If arr(i, 1) = num And arr(i, 3) <> 0 Then
            If firstMatch = False Then
                minValue = arr(i, colIndex)
                foundRow = i
                firstMatch = True
            ElseIf arr(i, colIndex) < minValue Then
                minValue = arr(i, colIndex)
                foundRow = i
            End If
        End If
    Next
    MinRowIndex = foundRow
End Function

gwjkkkkk

Option Explicit
Sub TEST2()
    Dim ar, br, cr, dr, i&, j&, vKey, dic(1) As New Dictionary
   
    Application.ScreenUpdating = False
   
    ar = Range("A2", Cells(Rows.Count, "C").End(xlUp)).Value
    br = Range("F2", Cells(Rows.Count, "L").End(xlUp)).Value
   
    ReDim Preserve ar(1 To UBound(ar), UBound(ar, 2))
    For j = 3 To 2 Step -1
        For i = 1 To UBound(ar)
            ar(i, j) = ar(i, j - 1)
        Next i
    Next j
    ar(1, 1) = "仓库名": ar(1, 3) = "调拔量"
   
    For i = 2 To UBound(ar)
        dic(0)(br(i, 1)) = dic(0)(br(i, 1)) & " " & i
    Next i
    For Each vKey In dic(0).keys
        cr = Split(dic(0)(vKey))
        For j = 4 To UBound(br, 2)
            ReDim dr(1 To UBound(cr), 1 To 3)
            For i = 1 To UBound(cr)
                dr(i, 1) = br(cr(i), 2)
                dr(i, 2) = br(cr(i), 3)
                dr(i, 3) = br(cr(i), j)
            Next i
            ShellSort2D dr, 1, UBound(dr), 1, UBound(dr, 2), 3
            dic(1)(vKey & Right(br(1, j), 1)) = dr
        Next j
    Next
   
    For i = 2 To UBound(ar)
        br = dic(1)(ar(i, 0) & ar(i, 1))
        For j = 1 To UBound(br)
            If br(j, 2) >= ar(i, 3) Then ar(i, 1) = br(j, 1): Exit For
        Next j
    Next i
        
    [P1].Resize(UBound(ar), UBound(ar, 2) + 1) = ar
    Application.ScreenUpdating = True
    Beep
End Sub

Function ShellSort2D(ByRef ar, ByVal iFirst&, ByVal iLast&, ByVal iLeft&, _
    ByVal iRight&, ByVal iKey&, Optional isOrder As Boolean = True)

    Dim iRowSize&, vTemp, interval&, i&, j&, k&

    ReDim vTemp(iLeft To iRight)
    iRowSize = iLast - iFirst + 1
    interval = 1

    If iRowSize > 13 Then
        Do While interval < iRowSize
            interval = interval * 3 + 1
        Loop
        interval = interval \ 9
    End If
   
    Do While interval
        For i = iFirst + interval To iLast
            For j = iLeft To iRight
                vTemp(j) = ar(i, j)
            Next
            If isOrder Then
                For k = i - interval To iFirst Step -interval
                    If ar(k, iKey) <= vTemp(iKey) Then Exit For
                    For j = iLeft To iRight
                         ar(k + interval, j) = ar(k, j)
                    Next j
                Next k
            Else
                For k = i - interval To iFirst Step -interval
                    If ar(k, iKey) > vTemp(iKey) Then Exit For
                    For j = iLeft To iRight
                        ar(k + interval, j) = ar(k, j)
                    Next j
                Next k
            End If
            For j = iLeft To iRight
                ar(k + interval, j) = vTemp(j)
            Next
        Next i
        interval = interval \ 3
    Loop

End Function

gwjkkkkk

参与一下。。。

blackttea1

有意思，谢谢分享

sdytsxd991122

标记一下