Excel VBA質問箱 IV

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

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


16835 / 76732 ←次へ | 前へ→

【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
0 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 お礼

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