[[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


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


コメント返信:

[ 一覧(最新更新順) ]


YukiWiki 1.6.7 Copyright (C) 2000,2001 by Hiroshi Yuki. Modified by kazu.