[[20211128145450]]　『出荷数に応じて在庫からの出荷数を計算したい』（MILK）　ページの最後に飛ぶ

『出荷数に応じて在庫からの出荷数を計算したい』（MILK）

A列2行目から8行目までが商品名
B列2行目から8行目までが在庫数
9行目に日々の出荷数
C列2行目から出荷する商品名とその個数
在庫が出荷数を下回った場合次の商品を充当して出荷数を確保
以下順に出荷数を確保していきたいと考えております
エクセルマクロでこの計算を実現したいと考えておりますが
ご教授いただけますでしょうか。
よろしくお願いいたします。

1　　A　　　　B　　　　C　　　　D　　　　E　　　　F　　　　G　　　　H　　　　I　　　　
2 リンゴA　　55　　リンゴA　　リンゴA　リンゴA　リンゴB　リンゴC　リンゴC　リンゴD　
3 リンゴB　　43　　　25　　　　25　　　　5　　　　23　　　25　　　　8　　　　5　　
4 リンゴC　　35　　　　　　　　　　　　リンゴB　リンゴC　　　　　　リンゴD　リンゴE
5 リンゴD　　22　　　　　　　　　　　　　20　　　　2　　　　　　　　17　　　　18
6 リンゴE　　18　　　　　　　　　　　　　　　　　　　　　　　　　　　　　　　リンゴG
7 リンゴG　　21　　　　　　　　　　　　　　　　　　　　　　　　　　　　　　　　2
8 リンゴH　　55
9 出荷数　　　　　　　25　　　　25　　　　25　　　25　　　25　　　　25　　　　25

＜使用 Excel：Excel2019、使用 OS：Windows10 ＞

どこまで出来ていて、どこで躓いているのでしょう？
（通りすがり） 2021/11/28(日) 17:30

表の大きさ（範囲）が固定なら

 Option Explicit

 Sub test()
    Dim q As Object
    Dim c As Range
    Dim d As Range
    Dim k As Long
    Dim 商品 As String, tmp As String

    Set q = CreateObject("system.collections.queue")

    For Each c In Range("A2:A8")
        商品 = c.Value
        For k = 1 To c.Offset(, 1).Value
            q.enqueue 商品
        Next
    Next

    For Each c In Range("C9:I9")
        Set d = c.EntireColumn.Range("A2:A3")
        tmp = q.peek
        d(1).Value = tmp
        For k = 1 To c.Value
            商品 = q.dequeue
            If tmp <> 商品 Then
                Set d = d.Offset(2)
                d(1).Value = 商品
                tmp = 商品
            End If
            d(2).Value = d(2).Value + 1
        Next
    Next

 End Sub

（マナ） 2021/11/28(日) 17:41

在庫が足らないとかのエラー等への対策は、一切していません。

（マナ） 2021/11/28(日) 17:48

データ範囲を可変にしました。
また在庫不足でメッセージをだすようにしました。

 Sub test2()
    Dim q As Object
    Dim r As Range
    Dim c As Range
    Dim d As Range
    Dim k As Long
    Dim 商品 As String

    Set q = CreateObject("system.collections.queue")

    Set r = Range("A1", ActiveSheet.UsedRange)
    Set r = Range(r.Rows(2), r.Rows(r.Rows.Count - 1))

    For Each c In r.Columns(1).SpecialCells(xlCellTypeConstants)
        商品 = c.Value
        For k = 1 To c.Offset(, 1).Value
            q.enqueue 商品
        Next
    Next
    q.enqueue "end"

    Set r = Intersect(r, r.Offset(, 2))
    r.ClearContents

    For Each c In r.Columns
        Set d = c.Range("A1:A2")
        d(1).Value = q.peek
        For k = 1 To c.Cells(c.Cells.Count + 1).Value
            商品 = q.dequeue
            If 商品 = "end" Then
                MsgBox "在庫が足りません"
                Exit Sub
            End If
            If d(1).Value <> 商品 Then
                Set d = d.Offset(2)
                d(1).Value = 商品
            End If
            d(2).Value = d(2).Value + 1
       Next
    Next

 End Sub

（マナ） 2021/11/28(日) 19:00

実際のデータでは出荷数が多く、時間がかかるようなら
結果の書き込みを、配列を使って１回で。
現在のレイアウトだと、１回の出荷あたりの、商品ロット数が多いと、
結果を書き込む場所が足りないケースが発生するかもしれません。

 Sub test3()
    Dim q As Object
    Dim r As Range
    Dim c As Range
    Dim v, y As Long, x As Long
    Dim k As Long
    Dim 商品 As String

    Set q = CreateObject("system.collections.queue")

    Set r = Range("A1", ActiveSheet.UsedRange)
    Set r = Range(r.Rows(2), r.Rows(r.Rows.Count - 1))

    For Each c In r.Columns(1).SpecialCells(xlCellTypeConstants)
        商品 = c.Value
        For k = 1 To c.Offset(, 1).Value
            q.enqueue 商品
        Next
    Next
    q.enqueue "end"

    Set r = Intersect(r, r.Offset(, 2))
    r.ClearContents
    v = r.Resize(r.Rows.Count + 1).Value

    For x = 1 To UBound(v, 2)
        y = 1
        v(y, x) = q.peek
        For k = 1 To v(UBound(v, 1), x)
            商品 = q.dequeue
            If 商品 = "end" Then
                MsgBox "在庫が足りません"
                Exit For
            End If
            If v(y, x) <> 商品 Then
                y = y + 2
                v(y, x) = 商品
            End If
            v(y + 1, x) = v(y + 1, x) + 1
        Next
        If 商品 = "end" Then Exit For
    Next

    r.Value = v

 End Sub

（マナ） 2021/11/28(日) 20:37

マナ様
ありがとうございます！
勉強不足を改めて感じました。
範囲固定のものにメッセージBOXを組み合わせて無事解決しました。
本日より業務に応用します。
（Milk） 2021/11/29(月) 11:40

 こんばんは、解決済ですが面白そうなので挑んでみました。
 Sub Test()
    Dim objList As Object, myDic As Object, 商品List As Variant
    Dim LastRow As Long, LastCol As Long, T1 As Long, T2 As Long
    Dim c As Range, i As Long, Rng As Range

    Set objList = CreateObject("System.Collections.ArrayList")
    LastRow = Cells(Rows.Count, "A").End(xlUp).Row
    LastCol = Cells(1, Columns.Count).End(xlToLeft).Column
    T1 = WorksheetFunction.Sum(Range("B2", Cells(LastRow - 1, "B")))
    T2 = WorksheetFunction.Sum(Range(Cells(LastRow, "C"), Cells(LastRow, LastCol)))
    Range("C2", Cells(LastRow - 1, LastCol)).ClearContents
    For Each c In Range("A2:A" & LastRow - 1)
        For i = 1 To c.Offset(, 1).Value
            objList.Add c.Value
        Next
    Next
    If T1 < T2 Then
        For i = 1 To T2 - T1
            objList.Add "不足数"
        Next
    End If
    商品List = objList.Toarray
    Dim d As Variant, sn As Long
    Set myDic = CreateObject("Scripting.Dictionary")
    For Each c In Range(Cells(LastRow, 3), Cells(LastRow, LastCol))
        Set Rng = Cells(2, c.Column)
        For i = 1 To c.Value
            myDic(商品List(sn)) = myDic(商品List(sn)) + 1
            sn = sn + 1
        Next
        For Each d In myDic.keys
            Rng.Value = d
            Rng.Offset(1).Value = myDic(d)
            Set Rng = Rng.Offset(2)
        Next
        myDic.RemoveAll
    Next
    Set objList = Nothing
    Set myDic = Nothing
 End Sub

（ピンク） 2021/12/01(水) 00:14

コメント返信：

[ 一覧(最新更新順) ]

[[20211128145450]] 『出荷数に応じて在庫からの出荷数を計算したい』（MILK） ページの最後に飛ぶ

[[20211128145450]]　『出荷数に応じて在庫からの出荷数を計算したい』（MILK）　ページの最後に飛ぶ