| |
>>色付けでは無く、記号を入れるとしたら何処に入れるのですか？
>>各シートのA車、B車・・の列は何か入っている様ですし？
>
>値の入ってるセルと同じセルに入れるつもりです
>
>例えば､ ●10
>って感じで､在庫数の前に入れることを考えています
だとすれば、前にUpしたコードを変更して、こんな形で善いのかな？
ただ、記号（色を付ける）条件が今一腑に落ちないので善く確認して下さい
Option Explicit
Public Sub Sample_2()
Dim TARGET() As Variant
Dim i As Long
Dim j As Long
Dim k As Long
Dim l 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
Dim vntSign() As Variant '★追加
'Dictionaryオブジェクトを取得
Set dicIndex = CreateObject("Scripting.Dictionary")
'出力する記号を列挙
vntSign = Array("◎", "●", "▲") '★追加
'*********************************
'在庫表を配列に取得
' 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
'値先頭に記号が有るかを確認
For l = 0 To UBound(vntSign) '★追加
If Left(vntData(k, 1), 1) = vntSign(l) Then '★追加
Exit For '★追加
End If '★追加
Next l
'頭に記号が有るなら
If l <= UBound(vntSign) Then '★追加
'値先頭に記号が有る場合此れを消去
vntData(k, 1) = Mid(vntData(k, 1), 2) '★追加
End If '★追加
'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 '★削除
vntData(k, 1) = vntSign(0) & vntData(k, 1) '★追加
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 '★削除
vntData(k, 1) = vntSign(1) & vntData(k, 1) '★追加
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 '★削除
vntData(k, 1) = vntSign(1) & vntData(k, 1) '★追加
TARGET(lngPos, 2) = TARGET(lngPos, 2) - vntItems(j, 2)
'必要数が仕掛より多かったら数不足の為、黄色
Else
' .Cells(k + 2 - 1, i).Interior.ColorIndex = 6 '★削除
vntData(k, 1) = vntSign(2) & vntData(k, 1) '★追加
TARGET(lngPos, 2) = 0
End If
End If
End If
End If
Next k
'配列を列データに出力
.Range(.Cells(2, i), .Cells(lngRows + 1, i)).Value = vntData '★追加
End With
Next j
Next i
Set dicIndex = Nothing
Application.ScreenUpdating = True
MsgBox "処理が完了しました", vbInformation
End Sub
|
|
Hirofumi
- 10/5/20(木) 15:49 -
