| |
▼さとちゃん さん：
一応バグをつぶしたつもりです。
Dictionaryの「嵐？」になりましたが。
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 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
Application.ScreenUpdating = False
Set dic使用 = CreateObject("Scripting.Dictionary")
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
If Not dic購入.exists(parts) Then Set dic購入(parts) = CreateObject("Scripting.Dictionary")
dic購入(parts)(order) = qty
dic注文(parts) = dic注文(parts) + 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
dic使用(parts) = dic使用(parts) + qty
Next
End With
With Sheets("Sheet3")
.Cells.ClearContents
.Range("A1:F1").Value = Array("号機", "部品番号", "使用数", "注文番号", "購入数", "余剰")
i = 1
For Each key部品 In dic生産
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
qty = qty - myAlloc.used
first = False
Loop While myAlloc.flag And qty > 0
Next
If dic注文(key部品) - dic使用(key部品) <> 0 Then _
.Cells(i, "F").Value = dic注文(key部品) - dic使用(key部品)
Next
End With
dic生産.RemoveAll
dic購入.RemoveAll
Set dic生産 = Nothing
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(土) 22:57 -
