Excel VBA質問箱 IV

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

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


2888 / 13646 ツリー ←次へ | 前へ→

【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 お礼[未読]

【65351】処理速度について
質問  かな  - 10/5/14(金) 8:56 -

引用なし
パスワード
   今、在庫と仕掛品の引当表を作っています。
現在のコードでは、とてもじゃないけど、莫大な時間を要してしまって、
使いものにならない状態です。
なんとか、処理が高速化するようにコードを変えたいのですが、
いまいち、良い方法が思いつきません

[シート1] 部品の在庫数と仕掛数の一覧です
部品名  在庫数  仕掛数
AAA     10    10
BBB     15    12
CCC     13    20
DDD     20    16
EEE     10     7
FFF     40    20

上記のようなデータが8000件ほどあります

[シート2]から10シートほどに渡って、総計で6万件のデータが下記のように
あります

列数は、100列程度あります
部品名 必要数 A車  B車  C車  D車  E車…以降、まだ続きます
AAA    2  ●   ●   ●   ● ←セルを引当可能なら塗りつぶす
CCC    2      ●   ●   ● 
AAA    2         ●   ●
BBB    4  ●   ●         
AAA    3      ●
EEE    7         ●      ●



行数は各シート毎でバラバラですが、多いシートで38000件あります
引当の順としては、A車のAAA、A車のCCC、A車のAAA、A車のBBB、A車のAAA、A車のEEE、B車のAAA…、といったように、列毎から順に見ていきます
これを、A車から、順に在庫と仕掛を引当していくのですが、
在庫引当可能なら、緑色に塗りつぶす
在庫が不足してる場合は、黄色に塗りつぶす
在庫が引当できなくて、仕掛引当可能ならピンクに塗りつぶす 

今のコードはこんな感じです

Dim TARGET() As Variant
Dim MyItem As String
Dim 必要数 As Long
Dim 最終C As Long
Dim 最終R As Long

Dim st As Single
st = Timer()

Sheets("シート1").Activate

i = 0

ReDim TARGET(Range("A" & Rows.Count).End(xlUp).Row, 2)
For i = 0 To Range("A" & Rows.Count).End(xlUp).Row
 If i > 3 Then
’在庫表のデータを全て配列に格納します
  TARGET(i - 4, 0) = Range("A" & i).Value
  TARGET(i - 4, 1) = Range("B" & i).Value
  TARGET(i - 4, 2) = Range("C" & i).Value
 End If
Next i
  
'*********************************
'全シートに在庫仕掛を引当する
'在庫=緑、仕掛=ピンク、不足=黄色
'*********************************
最終C = Sheets(2).Cells(1, Columns.Count).End(xlToLeft).Column

For r = 0 To UBound(TARGET)
  For x = 3 To 最終C  
    For y = 2 To Sheets.Count
    
      Worksheets(y).Activate

      最終R = Range("A" & Rows.Count).End(xlUp).Row
     
      For i = 2 To 最終R
       If TARGET(r, 0) = Cells(i, "A").Value Then      
         MyItem = Cells(i, 1).Value 'A列
         必要数 = Cells(i, 2).Value 'B列
        'もし、空白でなかったら、        
        If Cells(i, x).Value <> "" then   
        '必要数が在庫より少ない場合は緑(引当)
            If 必要数 <= TARGET(r, 1) Then
              Cells(i, x).Interior.ColorIndex = 4
              TARGET(r, 1) = TARGET(r, 1) - 必要数
        '必要数が在庫より多くて、在庫がゼロより多い場合は数不足の為、黄色
            ElseIf TARGET(r, 1) <= 必要数 And TARGET(r, 1) > 0 Then
              Cells(i, x).Interior.ColorIndex = 6
              TARGET(r, 1) = 必要数 - TARGET(r, 1)
              TARGET(r, 2) = TARGET(r, 2) - TARGET(r, 1)
              TARGET(r, 1) = 0 '完成引当の終了
        '必要数が仕掛より少ない場合はピンク(引当)
            ElseIf TARGET(r, 1) = 0 Then
              If 必要数 <= TARGET(r, 2) Then
               Cells(i, x).Interior.ColorIndex = 38
               TARGET(r, 2) = TARGET(r, 2) - 必要数
        '必要数が仕掛より多く、仕掛がゼロより多かったら数不足の為、黄色
              ElseIf TARGET(r, 2) <= 必要数 And TARGET(r, 2) > 0 Then
               Cells(i, x).Interior.ColorIndex = 6
               TARGET(r, 2) = 0
        '仕掛がゼロだったらループ抜ける
              ElseIf TARGET(r, 2) = 0 Then GoTo 抜ける
              End If
            End If
           End If
          'End If
        Else
          GoTo 抜ける
        End If
      Next i
     Next y
  Next x
抜ける:
  
Next r
           
End Sub

分かりにくいかもしれませんが、どうか良きアドバイスがありましたらお願いします

【65352】Re:処理速度について
発言  Hirofumi  - 10/5/14(金) 12:51 -

引用なし
パスワード
   このコードでは
C列に就いてSheet(2)〜最終シートまで処理
D列に就いてSheet(2)〜最終シートまで処理


最終列に就いてSheet(2)〜最終シートまで処理
と言う処理順で行っていますが?
此れは意味が有るのですか?

例えば、
Sheet(2)のC列〜最終列まで処理
Sheet(3)のC列〜最終列まで処理


最終シートのC列〜最終列まで処理
にしては行けないのですか?

【65353】Re:処理速度について
発言  かな  - 10/5/14(金) 13:24 -

引用なし
パスワード
   ▼Hirofumi さん:

>このコードでは
>C列に就いてSheet(2)〜最終シートまで処理
>D列に就いてSheet(2)〜最終シートまで処理
>・
>・
>最終列に就いてSheet(2)〜最終シートまで処理
>と言う処理順で行っていますが?
>此れは意味が有るのですか?
>
A.はい
 下記のようにすると、在庫の引当が変わってしまうため、上記のような処理法にしてあります


>例えば、
>Sheet(2)のC列〜最終列まで処理
>Sheet(3)のC列〜最終列まで処理
>・
>・
>最終シートのC列〜最終列まで処理
>にしては行けないのですか?

やっぱり、データ量も多いし、エクセルでは限界でしょうか?

【65355】Re:処理速度について
発言  neptune  - 10/5/14(金) 14:36 -

引用なし
パスワード
   ▼かな さん:

素朴な疑問ですが、
6万件もあるのに何故、セルの色を塗りつぶすのでしょう?
まさか6万件目視でチェックするんですか?

フィルタオプションを使用して、該当する箇所を塗りつぶすと現在よりは
速くなるとは思います。・・・複数条件で繰り返し必要ですが。
フィルタオプションはこの手の抽出は速いです。


>やっぱり、データ量も多いし、エクセルでは限界でしょうか?
やり方にもよるんでしょうが、多い事は多いですね。

Accessなどを使っても良いですが、Excelをつかうにしても
該当する奴だけを抽出してリスト作成した方が現実的かと思います。

【65360】Re:処理速度について
回答  Hirofumi  - 10/5/14(金) 16:46 -

引用なし
パスワード
   テストしていないので上手く行かないかも?
上手く動けば比較の部分が速く成るので幾分処理速度が上がるかも
ただ、所詮、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

【65361】Re:処理速度について
発言  よろずや  - 10/5/14(金) 18:34 -

引用なし
パスワード
   ▼かな さん:
>やっぱり、データ量も多いし、エクセルでは限界でしょうか?
はい、限界だと思います。
識者の皆さんの力で高速化が出来たとしても、
やりたい事はこれだけじゃないんでしょ。
これらのデータを使って〜〜もしたい、となったときに破綻します。
ここは、絶対にデータベースの導入を考えましょう。

【65371】Re:処理速度について
回答  H. C. Shinopy  - 10/5/15(土) 23:24 -

引用なし
パスワード
   万件単位のデータを扱うのであれば、
まず、ハードウェアから対処したらどうでしょう。

メモリーに空きがあれば増設する。
あるいはハードディスクの容量を増やす。(例えば250GBを1TBにする。)
SATAをSATA IIにするとか…(自分のパソコンのフタをはずして見たら、両規格接続できるようになっていました。)

その前に、取り敢えず、マクロには「Application.ScreenUpdating = False」
(無論、処理終了前に必ずTrueを指定)を追加。

それからIf文の一部はSelect Case文を使うほうがいいでしょう。
掲示マクロのIf文は下のような意味になるだろうと考えてみましたが、
果たして正しく動作するかどうか不明。御参考までに。

       If TARGET(r, 0) <> Cells(i, "A").Value Then
        GoTo 抜ける
       End If
       '
       myItem = Cells(i, 1).Value 'A列
       必要数 = Cells(i, 2).Value 'B列
       '
       'もし、空白でなかったら、
       If Cells(i, x).Value <> "" Then
        Select Case TARGET(r, 1)
         '
         ' 必要数が仕掛より少ない場合はピンク(引当)
         Case 0
          Select Case TARGET(r, 2)
           Case 0
            GoTo 抜ける
           Case Is > 必要数
            Cells(i, x).Interior.ColorIndex = 38
            TARGET(r, 2) = TARGET(r, 2) - 必要数
           Case Else ' 0 to 必要数
            Cells(i, x).Interior.ColorIndex = 6
            TARGET(r, 2) = 0
          End Select
          '
         ' 必要数が在庫より少ない場合は緑(引当)
         Case Is > 必要数
          Cells(i, x).Interior.ColorIndex = 4
          TARGET(r, 1) = TARGET(r, 1) - 必要数
        
         ' 必要数が在庫より多くて、在庫がゼロより多い場合は数不足の為、黄色
         Case Else ' 0 to 必要数
          Cells(i, x).Interior.ColorIndex = 6
          TARGET(r, 1) = 必要数 - TARGET(r, 1)
          TARGET(r, 2) = TARGET(r, 2) - TARGET(r, 1)
          TARGET(r, 1) = 0 '完成引当の終了
        End Select
       End If

【65380】Re:処理速度について
お礼  かな  - 10/5/17(月) 8:57 -

引用なし
パスワード
   ▼neptune さん:

ありがとうございます
とりあえず、必要なデータだけを別シートに抜き出して、
フィルタオプションを使用してやってみました、
まえよりは、早くなりましたが、このデータをまた元の場所にに戻さないといけないのですが、
なかなか、高速化となると、難しいですね

もう少し考えてみます

ありがとうございました

【65381】Re:処理速度について
お礼  かな  - 10/5/17(月) 8:58 -

引用なし
パスワード
   ▼Hirofumi さん:

ありがとうございます

早速解読して、試してみます

また、何か分からない部分があったら、お聞きするかもしれませんが、
よろしくお願いします

【65382】Re:処理速度について
お礼  かな  - 10/5/17(月) 9:02 -

引用なし
パスワード
   ▼よろずや さん:

やっぱり限界ですか…
現在のリストにするまではアクセスを使って処理していたのですが、
アクセスもいまいち分からないところがあって、
途中の処理からは、エクセルでやろうと思ってました

でも、万件データを扱うには、少し無理があるようですね…

アドバイスありがとうございました

【65383】Re:処理速度について
お礼  かな  - 10/5/17(月) 9:07 -

引用なし
パスワード
   ▼H. C. Shinopy さん:

Select Caseですね
いつも、IF文ばかり使っているので、Select Caseは慣れないのですが、
場合によってはSelect Caseを使ったほうがいいときもあるんですね

もう少し勉強してみます


データ多すぎだと、なかなかうまくいかないことが多くて悪戦苦闘しておりますが、いろいろとアドバイスを参考に考えてみます

ありがとうございました

【65394】Re:処理速度について
質問  かな  - 10/5/18(火) 8:40 -

引用なし
パスワード
   一つだけ質問があります
何度もすみません。

セルのバックカラーを色塗りしていくのと、
塗りつぶしの代わりに、セルに記号を入れていくのと、処理的には
どちらが、早いのでしょうか?

なんとか、今は、処理が遅くても、一応は作動しているのですが、
記号に変えたほうが、早く処理が終わるのかな?とふと思ったのですが…
どうなんでしょうか?
どうか、アドバイスお願いします

【65397】Re:処理速度について
発言  Hirofumi  - 10/5/18(火) 11:01 -

引用なし
パスワード
   ▼かな さん:
>一つだけ質問があります
>何度もすみません。
>
>セルのバックカラーを色塗りしていくのと、
>塗りつぶしの代わりに、セルに記号を入れていくのと、処理的には
>どちらが、早いのでしょうか?
>
>なんとか、今は、処理が遅くても、一応は作動しているのですが、
>記号に変えたほうが、早く処理が終わるのかな?とふと思ったのですが…
>どうなんでしょうか?
>どうか、アドバイスお願いします

方法にもよると思いますが?
記号を入れて行く方が、配列を使って一括代入等の処理が考えられるので
幾分速くする可能性は有ると思います

【65411】Re:処理速度について
回答  mura  - 10/5/19(水) 10:34 -

引用なし
パスワード
   >セルのバックカラーを色塗りしていくのと、
>塗りつぶしの代わりに、セルに記号を入れていくのと、処理的には
>どちらが、早いのでしょうか?

配列にてセルに記号を入れる方法が10倍以上は早いと思います。
以下速度テストの例
Sub test1()
 Dim rr As Range, rg As Range, tm!, vv, xx&, yy&
 Set rg = Range("a1:z10000")
 Cells.Clear
 tm = Timer
 For Each rr In rg
  If rr.Value = "" Then rr.Interior.Color = vbGreen
  'If rr.Value = "" Then rr.Value = "×"
 Next
 Debug.Print "Rangeオブジェクトの例 "; Timer - tm
 
 Cells.Clear
 tm = Timer
 vv = rg
 For xx = 1 To UBound(vv, 2)
  For yy = 1 To UBound(vv)
   If vv(yy, xx) = "" Then vv(yy, xx) = "○"
  Next
 Next
 rg = vv
 Debug.Print "配列の例 "; Timer - tm
End Sub

始めに示されたコードで
xx = Range("A" & i).Value
xx = Cells(i, 1).Value 
等の部分、要するにRangeオブジェクトの部分を
全て配列に直せば相当早くなるでしょう。
配列での処理はメモリへの直接アクセスなので最速です。

【65413】Re:処理速度について
お礼  かな  - 10/5/19(水) 12:30 -

引用なし
パスワード
   ▼Hirofumi さん:

>記号を入れて行く方が、配列を使って一括代入等の処理が考えられるので
>幾分速くする可能性は有ると思います

一括代入とかできるんですか?
アドバイスありがとうございました

詳しく配列の勉強してみます

【65414】Re:処理速度について
お礼  かな  - 10/5/19(水) 12:32 -

引用なし
パスワード
   ▼mura さん:
>
>配列にてセルに記号を入れる方法が10倍以上は早いと思います。

やっぱり配列に記号が早いんですね
サンプルコードありがとうございました

今から、試してみます

また不明な点が会ったら質問するかもしれませんが、
そのときはよろしくお願いします

【65416】Re:処理速度について
発言  Hirofumi  - 10/5/19(水) 13:31 -

引用なし
パスワード
   >>記号を入れて行く方が、配列を使って一括代入等の処理が考えられるので
>>幾分速くする可能性は有ると思います
>
>一括代入とかできるんですか?
>アドバイスありがとうございました
>
>詳しく配列の勉強してみます

色付けでは無く、記号を入れるとしたら何処に入れるのですか?
各シートのA車、B車・・の列は何か入っている様ですし?

【65435】Re:処理速度について
発言  かな  - 10/5/20(木) 14:03 -

引用なし
パスワード
   ▼Hirofumi さん:
>
>色付けでは無く、記号を入れるとしたら何処に入れるのですか?
>各シートのA車、B車・・の列は何か入っている様ですし?

値の入ってるセルと同じセルに入れるつもりです

例えば、 ●10
って感じで、在庫数の前に入れることを考えています

【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

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