Excel VBA質問箱 IV

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

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


3487 / 13644 ツリー ←次へ | 前へ→

【61871】消去作業について YOUSUKE 09/6/10(水) 1:05 質問[未読]
【61873】Re:消去作業について Hirofumi 09/6/10(水) 8:09 発言[未読]
【61876】Re:消去作業について Hirofumi 09/6/10(水) 9:47 回答[未読]
【61882】Re:消去作業について YOUSUKE 09/6/10(水) 13:51 お礼[未読]
【61895】Re:消去作業について YOUSUKE 09/6/11(木) 8:07 お礼[未読]
【61896】Re:消去作業について Hirofumi 09/6/11(木) 8:50 回答[未読]
【61897】Re:消去作業について Hirofumi 09/6/11(木) 10:42 発言[未読]
【61900】Re:消去作業について YOUSUKE 09/6/11(木) 14:13 お礼[未読]

【61871】消去作業について
質問  YOUSUKE  - 09/6/10(水) 1:05 -

引用なし
パスワード
   あるシートのデータが特定の条件を満たした時、複数のシートの同行番号の行を消去するマクロがあります。コードは以下の通りです。
しかし、動作が遅く、何が原因でこうなっているのかわかっていない状態です。
他に高速で処理できる書き方をご存知の方がおりましたらどうかアドバイスのほどよろしくお願いします。

For j = 800 To 1 Step -1
  If Worksheets("D1").Cells(j + 2, 130) = "" Or Worksheets("D1").Cells(j + 2, 1) < 50 Then
    Worksheets("D1").Rows(j + 2).Delete SHIFT:=xlUp
    Worksheets("D2").Rows(j + 2).Delete SHIFT:=xlUp
    Worksheets("D3").Rows(j + 2).Delete SHIFT:=xlUp
    Worksheets("D4").Rows(j + 2).Delete SHIFT:=xlUp
    Worksheets("D5").Rows(j + 2).Delete SHIFT:=xlUp
    Worksheets("D6").Rows(j).Delete SHIFT:=xlUp
  End If
Next

【61873】Re:消去作業について
発言  Hirofumi  - 09/6/10(水) 8:09 -

引用なし
パスワード
   セルの削除は、後ろにデータの在るセルの削除より、最後のセルの削除の方が速く成ると思います
また、1つづつの削除より、纏めて削除した方が速く成ると思います
因って、作業列を設けて、削除する行に印を振って整列等で纏めて削除します

【61876】Re:消去作業について
回答  Hirofumi  - 09/6/10(水) 9:47 -

引用なし
パスワード
   コードにするとこんなかな?
幾分速く成ると思います

Option Explicit

Public Sub Sample()

  Dim i As Long
  Dim lngRows As Long    'データ行数
  Dim lngCount As Long   '削除数
  Dim vntSheets As Variant '対象シート名の一覧
  Dim vntTop As Variant   '対象シートのデータ先頭行
  Dim vntColumns As Variant '対象シートの最終データ列位置
  Dim lngDelete() As Long   '削除行のFlag
  Dim vntKeys1 As Variant
  Dim vntKeys2 As Variant
  
  vntSheets = Array("D1", "D2", "D3", "D4", "D5", "D6")
  vntTop = Array(3, 3, 3, 3, 3, 1)
  vntColumns = Array(130, 130, 130, 130, 130, 130)
  
  lngRows = 800
  
  'D1シートに就いて
  With Worksheets(vntSheets(0))
    '130列のデータを配列に取得
    vntKeys1 = .Range(.Cells(vntTop(0), 130), _
            .Cells(vntTop(0) + lngRows - 1, 130)).Value
    '1列のデータを配列に取得
    vntKeys2 = .Range(.Cells(vntTop(0), 1), _
            .Cells(vntTop(0) + lngRows - 1, 1)).Value
  End With
  '削除Flag用の配列を確保
  ReDim lngDelete(1 To lngRows, 1 To 1)
  
  '削除Flagを作成
  For i = 1 To lngRows
    If vntKeys1(i, 1) = "" Or vntKeys2(i, 1) < 50 Then
      lngDelete(i, 1) = 1
      lngCount = lngCount + 1
    End If
  Next i
  
  '削除する行が在るなら
  If lngCount > 0 Then
    'シート一覧に基いて
    For i = 0 To UBound(vntSheets)
      With Worksheets(vntSheets(i))
        '最終列の後ろに削除Flagを出力
        .Cells(vntTop(i), vntColumns(i) + 1).Resize(lngRows).Value = lngDelete
        '削除FlagをKeyとしてListを整列
        .Cells(vntTop(i), 1).Resize(lngRows, vntColumns(i) + 1).Sort _
            key1:=.Cells(vntTop(i), vntColumns(i) + 1), Order1:=xlAscending, _
            Header:=xlNo, OrderCustom:=1, MatchCase:=False, _
            Orientation:=xlTopToBottom, SortMethod:=xlStroke
        '削除Flagが1の行を削除
        .Cells(vntTop(i) + lngRows - lngCount, 1).Resize(lngCount).EntireRow.Delete
        '削除Flagを削除
        .Cells(vntTop(i), vntColumns(i) + 1).EntireColumn.Delete
      End With
    Next i
  End If
  
End Sub

【61882】Re:消去作業について
お礼  YOUSUKE  - 09/6/10(水) 13:51 -

引用なし
パスワード
   Hirofumiさん、ご回答ありがとうございます。
ちょっと実験してみますので、うまくいきましたら改めて、お礼の投稿させていただきます。

【61895】Re:消去作業について
お礼  YOUSUKE  - 09/6/11(木) 8:07 -

引用なし
パスワード
   Hirofumi さんの言うとおりに、教えていただいた、コマンドでものすごく早くなりました。数倍、体感的には10倍くらい早い感じがします。ありがとうございます。
このコマンドなんですが、整列してまとめて、消去するだけでここまで早くなるも物なのでしょうか? 配列など巧みに使用されていますが、この辺も速度アップに関係しているのでしょうか?

【61896】Re:消去作業について
回答  Hirofumi  - 09/6/11(木) 8:50 -

引用なし
パスワード
   ▼YOUSUKE さん:
>Hirofumi さんの言うとおりに、教えていただいた、コマンドでものすごく早くなりました。数倍、体感的には10倍くらい早い感じがします。ありがとうございます。
>このコマンドなんですが、整列してまとめて、消去するだけでここまで早くなるも物なのでしょうか? 配列など巧みに使用されていますが、この辺も速度アップに関係しているのでしょうか?

Excelの行列の削除は、前のレスで書いた様に纏めて(特に後ろにデータが無い様にして)
削除する方がが速く成ると思います

また、基本的にセルに対する読み書きは、1つづつ行うと変数に対する其れと違い
非常に時間が掛かります
因って、在るセル範囲に対する読み出しを行う場合、一括して配列変数に読み込んで
この配列変数の値を使います
また、セル範囲に書き出す場合、配列変数を確保して此れに結果を書き込んだ上で
配列変数をセル範囲に出力した方が一般的に速く成ると思います

しかし、配列変数の使い方自体は難しい事は無いのですが?
配列変数はリソースを食いますので、無暗に巨大な配列変数を使うと帰ってパホーマンスに
影響を与えると思います
ですので、配列変数を使う場合、配列変数のサイズを考慮して使用するのが効果的だと思います

尚、今回は使用していませんが

  '画面更新を停止
  Application.ScreenUpdating = False
  
  '画面更新を再開
  Application.ScreenUpdating = True

を併用しても効果が有ると思います

Option Explicit

Public Sub Sample()

  Dim i As Long
  Dim lngRows As Long    'データ行数
  Dim lngCount As Long   '削除数
  Dim vntSheets As Variant '対象シート名の一覧
  Dim vntTop As Variant   '対象シートのデータ先頭行
  Dim vntColumns As Variant '対象シートの最終データ列位置
  Dim lngDelete() As Long   '削除行のFlag
  Dim vntKeys1 As Variant
  Dim vntKeys2 As Variant
  
  vntSheets = Array("D1", "D2", "D3", "D4", "D5", "D6")
  vntTop = Array(3, 3, 3, 3, 3, 1)
  vntColumns = Array(130, 130, 130, 130, 130, 130)
  
  lngRows = 800
  
  'D1シートに就いて
  With Worksheets(vntSheets(0))
    '130列のデータを配列に取得
    vntKeys1 = .Range(.Cells(vntTop(0), 130), _
            .Cells(vntTop(0) + lngRows - 1, 130)).Value
    '1列のデータを配列に取得
    vntKeys2 = .Range(.Cells(vntTop(0), 1), _
            .Cells(vntTop(0) + lngRows - 1, 1)).Value
  End With
  '削除Flag用の配列を確保
  ReDim lngDelete(1 To lngRows, 1 To 1)
  
  '削除Flagを作成
  For i = 1 To lngRows
    If vntKeys1(i, 1) = "" Or vntKeys2(i, 1) < 50 Then
      lngDelete(i, 1) = 1
      lngCount = lngCount + 1
    End If
  Next i
  
  '画面更新を停止
  Application.ScreenUpdating = False '★追加
    
  '削除する行が在るなら
  If lngCount > 0 Then
    'シート一覧に基いて
    For i = 0 To UBound(vntSheets)
      With Worksheets(vntSheets(i))
        '最終列の後ろに削除Flagを出力
        .Cells(vntTop(i), vntColumns(i) + 1).Resize(lngRows).Value = lngDelete
        '削除FlagをKeyとしてListを整列
        .Cells(vntTop(i), 1).Resize(lngRows, vntColumns(i) + 1).Sort _
            key1:=.Cells(vntTop(i), vntColumns(i) + 1), Order1:=xlAscending, _
            Header:=xlNo, OrderCustom:=1, MatchCase:=False, _
            Orientation:=xlTopToBottom, SortMethod:=xlStroke
        '削除Flagが1の行を削除
        .Cells(vntTop(i) + lngRows - lngCount, 1).Resize(lngCount).EntireRow.Delete
        '削除Flagを削除
        .Cells(vntTop(i), vntColumns(i) + 1).EntireColumn.Delete
      End With
    Next i
  End If
  
  '画面更新を再開
  Application.ScreenUpdating = True '★追加

  MsgBox "処理が完了しました", vbInformation '★追加
  
End Sub

【61897】Re:消去作業について
発言  Hirofumi  - 09/6/11(木) 10:42 -

引用なし
パスワード
   試しにこんな事して見ると効果の具合が解ると思います

コードの始まりと終わりで時刻を取って、その差をMsgBoxで表示します
削除対象のデータを同じ物を用意して下さい


先ず、Upされたコードで

Public Sub Test()

  Dim j As Long
  Dim sngTime1 As Single
  Dim sngTime2 As Single
  
  sngTime2 = Timer
    
  For j = 800 To 1 Step -1
    If Worksheets("D1").Cells(j + 2, 130) = "" Or Worksheets("D1").Cells(j + 2, 1) < 50 Then
      Worksheets("D1").Rows(j + 2).Delete SHIFT:=xlUp
      Worksheets("D2").Rows(j + 2).Delete SHIFT:=xlUp
      Worksheets("D3").Rows(j + 2).Delete SHIFT:=xlUp
      Worksheets("D4").Rows(j + 2).Delete SHIFT:=xlUp
      Worksheets("D5").Rows(j + 2).Delete SHIFT:=xlUp
      Worksheets("D6").Rows(j).Delete SHIFT:=xlUp
    End If
  Next j

  sngTime1 = Timer

  MsgBox "処理が完了しました" & vbLf & (sngTime1 - sngTime2), vbInformation
  
End Sub

次に、回答したコードで

Public Sub Sample()

  Dim i As Long
  Dim lngRows As Long    'データ行数
  Dim lngCount As Long   '削除数
  Dim vntSheets As Variant '対象シート名の一覧
  Dim vntTop As Variant   '対象シートのデータ先頭行
  Dim vntColumns As Variant '対象シートの最終データ列位置
  Dim lngDelete() As Long   '削除行のFlag
  Dim vntKeys1 As Variant
  Dim vntKeys2 As Variant
  
  Dim sngTime1 As Single
  Dim sngTime2 As Single
  
  sngTime2 = Timer
  
  vntSheets = Array("D1", "D2", "D3", "D4", "D5", "D6")
  vntTop = Array(3, 3, 3, 3, 3, 1)
  vntColumns = Array(130, 130, 130, 130, 130, 130)
  
  lngRows = 800
  
  'D1シートに就いて
  With Worksheets(vntSheets(0))
    '130列のデータを配列に取得
    vntKeys1 = .Range(.Cells(vntTop(0), 130), _
            .Cells(vntTop(0) + lngRows - 1, 130)).Value
    '1列のデータを配列に取得
    vntKeys2 = .Range(.Cells(vntTop(0), 1), _
            .Cells(vntTop(0) + lngRows - 1, 1)).Value
  End With
  '削除Flag用の配列を確保
  ReDim lngDelete(1 To lngRows, 1 To 1)
  
  '削除Flagを作成
  For i = 1 To lngRows
    If vntKeys1(i, 1) = "" Or vntKeys2(i, 1) < 50 Then
      lngDelete(i, 1) = 1
      lngCount = lngCount + 1
    End If
  Next i
  
  '画面更新を停止
  Application.ScreenUpdating = False '★追加
    
  '削除する行が在るなら
  If lngCount > 0 Then
    'シート一覧に基いて
    For i = 0 To UBound(vntSheets)
      With Worksheets(vntSheets(i))
        '最終列の後ろに削除Flagを出力
        .Cells(vntTop(i), vntColumns(i) + 1).Resize(lngRows).Value = lngDelete
        '削除FlagをKeyとしてListを整列
        .Cells(vntTop(i), 1).Resize(lngRows, vntColumns(i) + 1).Sort _
            key1:=.Cells(vntTop(i), vntColumns(i) + 1), Order1:=xlAscending, _
            Header:=xlNo, OrderCustom:=1, MatchCase:=False, _
            Orientation:=xlTopToBottom, SortMethod:=xlStroke
        '削除Flagが1の行を削除
        .Cells(vntTop(i) + lngRows - lngCount, 1).Resize(lngCount).EntireRow.Delete
        '削除Flagを削除
        .Cells(vntTop(i), vntColumns(i) + 1).EntireColumn.Delete
      End With
    Next i
  End If
  
  '画面更新を再開
  Application.ScreenUpdating = True '★追加

  sngTime1 = Timer

  MsgBox "処理が完了しました" & vbLf & (sngTime1 - sngTime2), vbInformation
  
End Sub

次に、回答したコードから、Key1、Key2、削除FlagのlngDeleteを廃し、
直接セルに対する読み書きに変更した物

Public Sub Sample_3()

'  配列変数を使用しない

  Dim i As Long
  Dim j As Long
  Dim lngRows As Long    'データ行数
  Dim lngCount As Long   '削除数
  Dim vntSheets As Variant '対象シート名の一覧
  Dim vntTop As Variant   '対象シートのデータ先頭行
  Dim vntColumns As Variant '対象シートの最終データ列位置
  
  Dim sngTime1 As Single
  Dim sngTime2 As Single
  
  sngTime2 = Timer
  
  vntSheets = Array("D1", "D2", "D3", "D4", "D5", "D6")
  vntTop = Array(3, 3, 3, 3, 3, 1)
  vntColumns = Array(130, 130, 130, 130, 130, 130)
  
  lngRows = 800
  
  '削除Flagを作成
  For i = 1 To lngRows
    '条件に合わない物に印を付ける
    If Not (Worksheets(vntSheets(0)).Cells(vntTop(0) + i - 1, 130).Value = "" _
        Or Worksheets(vntSheets(0)).Cells(vntTop(0) + i - 1, 1).Value < 50) Then
      For j = 0 To UBound(vntSheets)
        Worksheets(vntSheets(j)).Cells(vntTop(j) + i - 1, vntColumns(j) + 1).Value = "*"
      Next j
    Else
      lngCount = lngCount + 1
    End If
  Next i
  
  '画面更新を停止
  Application.ScreenUpdating = False '★追加
    
  '削除する行が在るなら
  If lngCount > 0 Then
    'シート一覧に基いて
    For i = 0 To UBound(vntSheets)
      With Worksheets(vntSheets(i))
        '削除FlagをKeyとしてListを整列
        .Cells(vntTop(i), 1).Resize(lngRows, vntColumns(i) + 1).Sort _
            key1:=.Cells(vntTop(i), vntColumns(i) + 1), Order1:=xlAscending, _
            Header:=xlNo, OrderCustom:=1, MatchCase:=False, _
            Orientation:=xlTopToBottom, SortMethod:=xlStroke
        '削除Flagが1の行を削除
        .Cells(vntTop(i) + lngRows - lngCount, 1).Resize(lngCount).EntireRow.Delete
        '削除Flagを削除
        .Cells(vntTop(i), vntColumns(i) + 1).EntireColumn.Delete
      End With
    Next i
  End If
  
  '画面更新を再開
  Application.ScreenUpdating = True '★追加

  sngTime1 = Timer

  MsgBox "処理が完了しました" & vbLf & (sngTime1 - sngTime2), vbInformation
  
End Sub

私の機器では、
元々のコードで:約 7.44秒
回答のコードで:約 0.32秒
廃したコードで:約 0.42秒

800行程度ですので、余り差は無い様ですが配列変数を使った方が効果は有ります

【61900】Re:消去作業について
お礼  YOUSUKE  - 09/6/11(木) 14:13 -

引用なし
パスワード
   Hirofumiさん、度々回答ありがとうございます。
こんな風に、TIMERを利用して、速度の向上を確認するのも、勉強になっていいですね。今度からやってみようと思います。
しかし、私の元のコマンドと比較したら、20倍以上ですか?すばらしい結果ですね。ちょっとした工夫でこうも変わるとは恐ろしいものです。
ちなみに、画面更新の停止は一応私も付けておりましたが理解不能なほどに重かったです。ですので、この喜びも一塩でした。
Hirofumiさんの投稿など拝見して勉強するのもありだなと思いました。すばらしい情報どうもありがとうございました。

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