[ 初めての方へ | 一覧(最新更新順) | 全文検索 | 過去ログ ]
『出荷数に応じて在庫からの出荷数を計算したい』(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 >
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
こんばんは、解決済ですが面白そうなので挑んでみました。 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.