Excel　VBA　データ削除の高速化

Question

今晩は，質問させていただきます．どうぞよろしくお願いいたします．
　Win7 + Excel2007でございます。

B～D列の、1～300,000行程にデータが入っており、グラフ化する際に重いです。
そこでこれを周期的に間引く為に
（例えば、10行消して1行残す→また10行消して・・・の繰り返し）、

.Range(.Cells(行1, 2), .Cells(行2, 4)).Delete Shift:=xlUp

を繰り返すコードを作成いたしました。
が、非常に動作が遅く、数千行実行するのにも暫く時間がかかるほどでございます。。。

原因を解明すべく検索いたしておりますと、VBAの中でもデータ削除が原因で
マクロ動作が遅くなるケースは珍しく無いようでございます。
他のコーディング方法で何か、上記より早い方法というのは
あるのでございますでしょうか？
　もしお詳しい方がいらっしゃいましたら，是非アドバイスいただけないでしょうか。
どうぞよろしくお願いいたします。

Randomize#1 · Accepted Answer

押してダメなら引いてみるという考えで少し変わった解法を紹介します。
　行を削除する時にExcel内では削除により範囲の結果が変化する影響の評価などを内部で行なっているため、回数が重なるほどどんどん重たくなってしまいます。
　そこで逆転の発想、「消したらダメなら抜き取ったデータをどこかに表示すればいいじゃない」というのがこの解法の基本目的です。まずはソースから。特殊なことはしていないのでExcel2007でも問題なく動作するとは思いますが、当方の環境がExcel2003までですので、動かなかった場合はすみません。

'=====プログラムここから=====
Private Sub ThinOutData()
    Dim varRangeReadData() As Variant, varRangeWriteData() As Variant
    Dim NowReadRow As Long, MaxReadRow As Long, NowWriteRow As Long
    Dim NowReadColumn As Long
    
    Const MaxReadColumn As Long = 4 '表の列数を指定
    Const SkipRowNum As Long = 10   '何行に1個のデータを抽出するかを指定
    
    With ThisWorkbook.Worksheets("Sheet1") '処理対象のシートを記入してください
        MaxReadRow = .Cells(.Rows.Count, 1).End(xlUp).Row   '最終行を取得
        '元データを変数へコピー(タイトル行は除くので2行目から格納)
        varRangeReadData = .Range(.Cells(2, 1), .Cells(MaxReadRow, MaxReadColumn)).Value
        '最終行の数より、抽出するデータ範囲を準備する
        ReDim varRangeWriteData(1 To Int(MaxReadRow / SkipRowNum) + 1, 1 To MaxReadColumn)
        MaxReadRow = UBound(varRangeReadData, 1)  '最終行を数字を変数の行数に変更しておく
        '抽出開始
        NowWriteRow = 1
        For NowReadRow = 1 To MaxReadRow Step SkipRowNum
            '列内容を複写
            For NowReadColumn = 1 To MaxReadColumn
                varRangeWriteData(NowWriteRow, NowReadColumn) = varRangeReadData(NowReadRow, NowReadColumn)
            Next
            NowWriteRow = NowWriteRow + 1
        Next
        '結果をExcelへ書き出す
        '結果を書き出したい場所の左上を指定してください
        With .Range("H1")
            'まずはタイトル行をコピーしてくる
            .Parent.Range(.Offset(0, 0), .Offset(0, MaxReadColumn - 1)).Value = .Parent.Range(.Parent.Cells(1, 1), .Parent.Cells(1, MaxReadColumn)).Value
            .Parent.Range(.Offset(1, 0), .Offset(UBound(varRangeWriteData, 1) - 1, MaxReadColumn - 1)).Value = varRangeWriteData
        End With
    End With
End Sub
'=====プログラムここまで=====

元のデータはA1に左上詰めで記入されているもの仮定しています。
　Excelのデータ処理は、読み込みは早いが書き込みと消去は遅いです。よって、いかにこれらの作業を1回にまとめるかが高速化の鍵になります。

このプログラムには1個の知恵と1個のテクニックが用いられています。
　知恵の方は、以下に消去の回数を減らすかということの裏返しですね。消すのではなく、新たにどこかに記入することでちまちまとした削除する作業を0回にしてしまおうというものです。
　テクニックの方は、毎回毎回Excelのセルに書き込むとそのたびにExcelが内容が正しいか、内容がどの種類であるかを確認する作業が入るためどうしても処理が遅くなってしまいます。そのため、一旦2次元配列変数の中にデータを格納してしまい、それを一気にExcelへ転送して書きこむことをします。それによって、Excelが内容を確認するのは1回のみになるので、これだけでも処理速度は10～30倍近く早くなります。これを解説しているサイトを1個紹介します。
http://officetanaka.net/excel/vba/speed/s11.htm

ちなみに、このプログラムで処理した場合と元々のDeleteで処理した場合の速度ですが、65500行を処理するのにDeleteでは138秒かかるのに対し、回答のプログラムの方は0.09秒で処理を完了できました。

このプログラムは、With .Range("H1")の部分を変更することで出力先を変更することができますが、このプログラムのままではほかシートへ出力することはできません。もし、他のシートへ出力したい場合は、With .Range("H1")以下のプログラムを少しいじってあげてください。(タイトル行のコピーの部分をなくせば「.Range("H1")」の部分を変更するだけで対応は出来ます。)

あと補足ですが、この回答のプログラムでは、書き込み回数が1回のためScreenUpdatingプロパティーをいじっていません。(1回だけですので再描画制御をしなくても十分高速なため)　もし、何度も書き込みやセルの書式を変更や削除をするなどを行う場合はScreenUpdatingを処理中はFalseに設定する事を勧めます。

そして前の回答にあるのですが、DoEventsは処理中に他のイベントがあったかを確認するためのもので、中止処理を実装する時等以外は単に処理時間を長くしてしまうだけです。進捗状況を確認させたい場合はApplication.Statusbarを用いてExcelのステータスバーに進捗の文字列を表示する方が好ましいです。ただし、こちらも更新頻度を密にしすぎると無駄に処理時間を伸ばすだけですので、0.1秒に1回表示位の頻度に抑えておくのがよろしいでしょう。
timeGetTime APIを用いているのですが、このような実装です。timeGetTime APIの使い方は他サイトを参考にしてください

'宣言部
Private Declare Function timeGetTime Lib "winmm.dll" () As Long

'実際に使用している部分　これをループ処理の中に記述すると進捗状況の概要がステータスバーに表示されます
If LastTime + 100 <= timeGetTime Then  '前回表示から100ミリ秒以上経過している場合
　　Application.StatusBar = "現在、" & NowRowCount & "行目を処理中です..."
　　LastTime = timeGetTime
End If

'終わったら
Application.StatusBar = False  'Falseを代入するとステータスバーの内容がクリアされます

今後のステップアップの糧になれば幸いです。

hallo-2007 · Answer

>グラフ化する際に重いです。
パソコンの仕様が限界？
>数千行実行するのにも暫く時間がかかるほどでございます
データを利用した関数が設定されている？
VBAを実行＝＞削除されると関数が実行の繰り返しになっているのでは？

ここは、方向性を変えて
新しいブックを作って、１０行おきにデータをコピーしてみる方法は如何でしょうか。
こんな感じでは如何でしょうか。

Sub ボタン1_Click()
Workbooks.Add
J = 1
For i = 1 To 300000 Step 10
Range("B" & J & ":D" & J).Value = ThisWorkbook.Sheets(1).Range("B" & i & ":D" & i).Value
J = J + 1
Next
End Sub
元データも残りますし便利かと思いますが。

keithin · Answer

A1:D300000に生数字のデータが入っている条件で実測してみると3.6秒でした。

Sub macro4()
　Range("F1") = Timer
　Range("E1") = 1
　Range("E1:E11").AutoFill Destination:=Range("E1:E300000")
　Cells.Sort key1:=Range("E1"), order1:=xlAscending, Header:=xlNo
　Range(Cells(Cells.Rows.Count, "E").End(xlUp).Offset(1), Cells(Cells.Rows.Count, "A").End(xlUp)).EntireRow.Delete
　Range("G1") = Timer
End Sub

f272 · Answer

データのある列の横の列に
残したいところは0
消したいところは1
のようにデータを作って，それをキーにして並べ替えを行い，最後に一気に削除する。

tohru999 · Answer

どの程度軽減できるかわかりませんが．．．
試しに、
Deleteの前に
Application.ScreenUpdating = False

繰り返し処理終了後に
Application.ScreenUpdating = True

を入れてみてはどうでしょうか？

後、余計なお世話かもしれませんが、
削除処理が大量にあり時間がかかる場合は、フリーズしている？と思われてしまうので
繰り返し処理中に
DoEvents()
を入れてみるのも良いかも

Excel VBA データ削除の高速化

押してダメなら引いてみるという考えで少し変わった解法を紹介します。

この回答への補足

>グラフ化する際に重いです。

A1:D300000に生数字のデータが入っている条件で実測してみると3.6秒でした。

データのある列の横の列に

どの程度軽減できるかわかりませんが．．．

似たような質問が見つかりました

このQ&Aを見た人はこんなQ&Aも見ています

関連するカテゴリからQ&Aを探す

このQ&Aを見た人がよく見るQ&A

デイリーランキングこのカテゴリの人気デイリーQ&Aランキング

マンスリーランキングこのカテゴリの人気マンスリーQ&Aランキング

Excel　VBA　データ削除の高速化

　押してダメなら引いてみるという考えで少し変わった解法を紹介します。