| |
▼さとちゃん さん：
本件、コードというより、業務仕様というかビジネスロジックのおおげさにいえばアルゴリズムを
どのようにするかというテーマだろうと思いますし、その場合、目的によっては、このシートレイアウトでいいのかどうかも
掘り下げていく余地はあるのかなとも思いますが、それはさておき、一例です。
（要件を誤解している可能性もあります。まずはお試しください）
Option Explicit
Type Alloc
PO As String
used As Long
flag As Boolean
End Type
Dim dic購入 As Object
Sub Sample()
Dim dic合計 As Object
Dim dic生産 As Object
Dim c As Range
Dim i As Long
Dim key部品 As Variant
Dim key号機 As Variant
Dim key注文 As Variant
Dim qty As Long
Dim orgqty As Long
Dim order As String
Dim parts As String
Dim machine As String
Dim myAlloc As Alloc
Dim first As Boolean
Dim allocated As Long
Dim remainder As Long
Application.ScreenUpdating = False
Set dic合計 = CreateObject("Scripting.Dictionary")
Set dic購入 = CreateObject("Scripting.Dictionary")
Set dic生産 = CreateObject("Scripting.Dictionary")
With Sheets("Sheet1")
For Each c In .Range("A2", .Range("A" & .Rows.Count).End(xlUp))
parts = c.Value
qty = c.Offset(, 2).Value
order = c.Offset(, 1).Value
dic合計(parts) = dic合計(parts) + qty
If Not dic購入.exists(parts) Then Set dic購入(parts) = CreateObject("Scripting.Dictionary")
dic購入(parts)(order) = qty
Next
End With
With Sheets("Sheet2")
For Each c In .Range("A2", .Range("A" & .Rows.Count).End(xlUp))
parts = c.Offset(, 1).Value
qty = c.Offset(, 2).Value
machine = c.Value
If Not dic生産.exists(parts) Then Set dic生産(parts) = CreateObject("Scripting.Dictionary")
dic生産(parts)(machine) = qty
Next
End With
With Sheets("Sheet3")
.Cells.ClearContents
.Range("A1:F1").Value = Array("号機", "部品番号", "使用数", "注文番号", "購入数", "余剰")
i = 1
For Each key部品 In dic生産
allocated = 0
For Each key号機 In dic生産(key部品)
first = True
qty = dic生産(key部品)(key号機)
orgqty = qty
Do
i = i + 1
.Cells(i, "A").Value = key号機
.Cells(i, "B").Value = key部品
If first Then .Cells(i, "C").Value = qty
myAlloc = getQty(key部品, qty)
.Cells(i, "D").Value = myAlloc.PO
.Cells(i, "E").Value = myAlloc.used
allocated = allocated + myAlloc.used
qty = qty - myAlloc.used
first = False
Loop While myAlloc.flag And qty > 0
Next
remainder = dic合計(key部品) - allocated
If remainder <> 0 Then .Cells(i, "F").Value = remainder
Next
End With
dic生産.RemoveAll
dic購入.RemoveAll
Set dic生産 = Nothing
Set dic購入 = Nothing
Set dic合計 = Nothing
Application.ScreenUpdating = True
MsgBox "処理が終了しました"
End Sub
Private Function getQty(parts As Variant, qty As Long) As Alloc
Dim ord As Variant
Dim blc As Long
If dic購入(parts).Count = 0 Then Exit Function
For Each ord In dic購入(parts)
blc = dic購入(parts)(ord)
If blc >= qty Then
getQty.used = qty
dic購入(parts)(ord) = blc - qty
Else
getQty.used = blc
dic購入(parts)(ord) = 0
End If
getQty.PO = ord
getQty.flag = True
If dic購入(parts)(ord) = 0 Then
dic購入(parts).Remove (ord)
End If
Exit For
Next
End Function
|
|
UO3
- 11/8/27(土) 19:28 -
