Excel VBA質問箱 IV

当質問箱は、有志のボランティア精神のおかげで成り立っています。
問題が解決したら、必ずお礼をしましょうね。
本サイトの基本方針をまとめました。こちら をご一読ください。

投稿種別の選択が必要です。ご注意ください。
迷惑投稿防止のため、URLの入力を制限しています。ご了承ください。


16757 / 76732 ←次へ | 前へ→

【65439】Re:処理速度について
回答  Hirofumi  - 10/5/20(木) 15:49 -

引用なし
パスワード
   >>色付けでは無く、記号を入れるとしたら何処に入れるのですか?
>>各シートの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

2 hits

【65351】処理速度について かな 10/5/14(金) 8:56 質問
【65352】Re:処理速度について Hirofumi 10/5/14(金) 12:51 発言
【65353】Re:処理速度について かな 10/5/14(金) 13:24 発言
【65355】Re:処理速度について neptune 10/5/14(金) 14:36 発言
【65380】Re:処理速度について かな 10/5/17(月) 8:57 お礼
【65360】Re:処理速度について Hirofumi 10/5/14(金) 16:46 回答
【65381】Re:処理速度について かな 10/5/17(月) 8:58 お礼
【65361】Re:処理速度について よろずや 10/5/14(金) 18:34 発言
【65382】Re:処理速度について かな 10/5/17(月) 9:02 お礼
【65371】Re:処理速度について H. C. Shinopy 10/5/15(土) 23:24 回答
【65383】Re:処理速度について かな 10/5/17(月) 9:07 お礼
【65394】Re:処理速度について かな 10/5/18(火) 8:40 質問
【65397】Re:処理速度について Hirofumi 10/5/18(火) 11:01 発言
【65413】Re:処理速度について かな 10/5/19(水) 12:30 お礼
【65416】Re:処理速度について Hirofumi 10/5/19(水) 13:31 発言
【65435】Re:処理速度について かな 10/5/20(木) 14:03 発言
【65439】Re:処理速度について Hirofumi 10/5/20(木) 15:49 回答
【65411】Re:処理速度について mura 10/5/19(水) 10:34 回答
【65414】Re:処理速度について かな 10/5/19(水) 12:32 お礼

16757 / 76732 ←次へ | 前へ→
ページ:  ┃  記事番号:
2610219
(SS)C-BOARD v3.8 is Free