| |
テストしていないので上手く行かないかも？
上手く動けば比較の部分が速く成るので幾分処理速度が上がるかも
ただ、所詮、1つ1つセルのBackColorを変えて居るので、遅い処理と思います
Option Explicit
Public Sub Sample_1()
Dim TARGET() As Variant
Dim i As Long
Dim j As Long
Dim k As Long
Dim lngPos As Long
Dim lngRows As Long
Dim lngColumns As Long
Dim vntData() As Variant
Dim vntItems() As Variant
Dim dicIndex As Object
'Dictionaryオブジェクトを取得
Set dicIndex = CreateObject("Scripting.Dictionary")
'*********************************
'在庫表を配列に取得
' DictionaryにIndexを作り、部品名で辞書引き出来る様に
'*********************************
With Sheets("シート1")
'最終行を取得
lngRows = .Range("A" & Rows.Count).End(xlUp).Row
'部品名を配列に取得
TARGET = .Range(.Cells(4, "A"), .Cells(lngRows + 1, "A")).Value
'部品名をKeyとして行位置をDictionaryに登録
For i = 1 To UBound(TARGET, 1) - 1
dicIndex(TARGET(i, 1)) = i
Next i
'在庫数、仕掛数を配列に取得
TARGET = .Range(.Cells(4, "B"), .Cells(lngRows, "C")).Value
End With
'*********************************
'全シートに在庫仕掛を引当する
'在庫＝緑、仕掛＝ピンク、不足＝黄色
'*********************************
' Application.ScreenUpdating = False
'最終列取得
lngColumns = Sheets(2).Cells(1, Columns.Count).End(xlToLeft).Column
'データ先頭列から最終列まで繰り返し
For i = 3 To lngColumns
'Sheet(2)〜最終シートまで繰り返し
For j = 2 To Worksheets.Count
With Worksheets(j)
'最終行取得
lngRows = .Cells(Rows.Count, "A").End(xlUp).Row
'出力シートの部品名、必要数を配列に取得
'vntItems(j,1)は部品名、vntItems(j,2)は必要数
vntItems = .Range(.Cells(2, "A"), .Cells(lngRows, "B")).Value
'列データを配列に取得
vntData = .Range(.Cells(2, i), .Cells(lngRows + 1, i)).Value
'データ先頭行〜最終行まで繰り返し
For k = 1 To lngRows - 2 + 1
'もし、空白でなかったら、
If vntData(k, 1) <> "" Then
'Dictionaryに該当部品が有った場合
If dicIndex.Exists(vntItems(k, 1)) Then
'在庫表の行位置を取得
lngPos = dicIndex.Item(vntItems(k, 1))
'必要数が在庫より少ない場合は緑（引当）
If TARGET(lngPos, 1) >= vntItems(j, 2) Then
.Cells(k + 2 - 1, i).Interior.ColorIndex = 4
TARGET(lngPos, 1) = TARGET(lngPos, 1) - vntItems(j, 2)
'必要数が在庫より多くて、在庫がｾﾞﾛより多い場合は数不足の為、黄色
ElseIf TARGET(lngPos, 1) < vntItems(j, 2) _
And TARGET(lngPos, 1) > 0 Then
.Cells(k + 2 - 1, i).Interior.ColorIndex = 6
TARGET(lngPos, 2) _
= TARGET(lngPos, 2) + TARGET(lngPos, 1) - vntItems(j, 2)
TARGET(lngPos, 1) = 0 '完成引当の終了
'在庫が無いなら
ElseIf TARGET(lngPos, 1) = 0 Then
'必要数が仕掛より少ない場合はﾋﾟﾝｸ（引当）
If TARGET(lngPos, 2) >= vntItems(j, 2) Then
.Cells(k + 2 - 1, i).Interior.ColorIndex = 38
TARGET(lngPos, 2) = TARGET(lngPos, 2) - vntItems(j, 2)
'必要数が仕掛より多かったら数不足の為、黄色
Else
.Cells(k + 2 - 1, i).Interior.ColorIndex = 6
TARGET(lngPos, 2) = 0
End If
End If
End If
End If
Next k
End With
Next j
Next i
Set dicIndex = Nothing
Application.ScreenUpdating = True
MsgBox "処理が完了しました", vbInformation
End Sub
|
|
Hirofumi
- 10/5/14(金) 16:46 -
