VBA高速化

Question

お世話になっております。

ここで質問し、皆様のご協力の下、なんとか差分抽出マクロを完成させましたが、
実行してみると、すごく遅いです。処理が終わるまで、133秒程度かかり、マクロ実行中は、Excelがフリーズしたような状態になります。。。。データー量としては、3,000行程度です。
(これだと普通にExcelの関数を使った方が早い状態です)

そこで、処理を高速化するために、コードをどのように修正していけば良いでしょうか？

このマクロを作ることにより、結構、ループや条件分岐や変数の概念が分かるようになり、かなり勉強になりました。

ただ、もっと、高速化を図りたいですね。。。

↓今回作成し、実行したコード↓

'作業前データーは、A～F列に貼り付ける。
'作業後データーは、I～N列に貼り付ける。

Sub MyDiff()
    Dim cRow As Long
    Dim befor_Area As Range '作業前対象範囲
    Dim befor_Rng As Variant '作業後対象範囲内のセルを格納する変数
    Dim kRow As Long
    Dim after_Area As Range '作業後対象範囲
    Dim after_Rng As Variant '作業後対象範囲内のセルを格納する変数
    Dim c As Long 'C列用カウンター変数
    Dim k As Long 'K列用カウンター変数
    Dim h As Long 'H列用カウンター変数
    Dim diff As Long
    Dim hRow As Long
        
    cRow = Cells(Rows.Count, "C").End(xlUp).Row 'C列の最終行取得
    kRow = Cells(Rows.Count, "K").End(xlUp).Row 'K列の最終行取得
    
    '作業前のMACアドレスで昇順にソート
    Range(Cells(2, 1), Cells(cRow, 6)).Sort _
        key1:=Range("C2"), _
        Order1:=xlAscending, _
        Header:=xlYes
        
     '作業後のMACアドレスで昇順にソート
    Range(Cells(2, 9), Cells(kRow, 13)).Sort _
        key1:=Range("K2"), _
        Order1:=xlAscending, _
        Header:=xlYes
    
    '作業前データーの空白チェック。
    '空白があった場合は、空白に-を入れる。
    
    
    Set befor_Area = Range(Cells(3, "A"), Cells(cRow, "F"))
    
    For Each befor_Rng In befor_Area
        If befor_Rng.Value <> "" Then
            '何もしない
        Else
            befor_Rng.Value = "-"
        End If
    Next
    
    '作業後データーの空白チェック。
    '空白があった場合は、空白に-を入れる。
    
    Set after_Area = Range(Cells(3, "I"), Cells(kRow, "N"))
    
    For Each after_Rng In after_Area
        If after_Rng.Value <> "" Then
            '何もしない
        Else
            after_Rng.Value = "-"
        End If
    Next
    
    
    'C列を元に、K列のMACアドレスのチェックを行う。
    '差分があった場合、G列に×を入れる。
    Cells(2, "G").Value = "差分1"
    c = 3
    
    Do While Cells(c, "C").Value <> ""
        k = 3
        Cells(c, "G").Value = "×"
        Do While Cells(k, "K").Value <> ""
            If Cells(c, "C").Value = Cells(k, "K").Value Then
                Cells(c, "G").Value = ""
                Exit Do
            End If
            k = k + 1
        Loop
    c = c + 1
    Loop
    
    'K列を元に、C列のMACアドレスのチェックを行う。
    '差分があった場合、H列に×を入れる。
    Cells(2, "H").Value = "差分2"
    
    k = 3
    Do While Cells(k, "K").Value <> ""
        c = 3
        Cells(k, "H").Value = "×"
        Do While Cells(c, "C").Value <> ""
            If Cells(k, "K").Value = Cells(c, "C").Value Then
                Cells(k, "H").Value = ""
                Exit Do
            End If
            c = c + 1
        Loop
        k = k + 1
    Loop
    
    
    'H列に"×"がるものデーター(H列～N列)をP列～V列へ移動させる。
    kRow = Cells(Rows.Count, "K").End(xlUp).Row
    hRow = kRow
    diff = 3
    
    For h = 3 To hRow
    
        If Cells(h, "H").Value <> "" Then
            Range(Cells(h, "H"), Cells(h, "N")).Cut Destination:=Range(Cells(diff, "P"), Cells(diff, "V"))
            diff = diff + 1
        End If
    Next h
    
End Sub

ご教授下さい。

Answer 1

ついに完成されたのですね！お疲れ様です。

さて、ステップインでpipiさんが作成したコードを実行したところ、
MACアドレスの差分チェックに時間が掛かってしまっているようです。

対策としては、K列にC列と異なる値があるか1行1行チェックするのではなく、
FindメソッドでまとめてC列をチェックすれば、かなりの高速化が図れるのではないかと思います。

Dim result As Range  '差分チェックの結果
k = 3

Do While Cells(k, "K").Value <> ""
    '差分チェック
    Set result = Range(Cells(3, "C"), Cells(cRow, "C")).Find(What:=Cells(k, "K").Value)
    '差分があった場合、H列に×を入れる
    If Not result Is Nothing Then
        Cells(k, "H").Value = "×"
    End If
    'ループカウンタ加算
    k = k + 1
Loop

また、_katoさんのアドバイスにある無駄な表示を止めるというのも効果的な方法です。
データ移動処理の高速化に貢献してくれるはずです。
（Excelの設定を変更するメソッドなので、Trueにするのを忘れないこと）

Application.ScreenUpdating = False  '画面描写を停止
Application.ScreenUpdating = True   '画面描写を再開

Comments

[退会済みユーザー]

アドバイス有難うございます。オブジェクト変数を学習し、もっと高速に処理できるように書き換えてみます。

Answer 2

まずは以下のページの、1.無駄な表示を止めるをやってみてはどうでしょうか？
簡単だけど効果は大きいです。
VBA高速化テクニック

それでも遅い場合は、無駄な処理やロジックをひとつづつ見直していく必要があります。
その場合も、上記のサイトの、2.からの項目が大変参考になります。

Answer 3

抜本的な解決になるかわかりませんが・・。
G列とH列に一度「Ｘ」を入れて値が同じなら空白に書き直しているのが
気になりました。

最初にG列とH列をすべて空白を書き込んだうえで、値が同じでないものについて
「Ｘ」を入れるようにしたほうが良いと思います。

最初にG列とH列を空白にしておく
→VBA実行前に何か文字が入っていてもG列とH列は空白になる
Columns("G").Clear
Columns("H").Clear

do whileの2行後のXを入れている行を消去
Cells(c, "G").Value = "×"
Cells(c, "H").Value = "×"

イコールの時に空白にするのではなく、異なるときに「Ｘ」を入れるようにする
(変更前)
If Cells(c, "C").Value = Cells(k, "K").Value Then
Cells(c, "G").Value = ""
Exit Do

(変更後)
If Cells(c, "C").Value <> Cells(k, "K").Value Then
Cells(c, "G").Value = "×"
Exit Do

※H列も同じようにやってください。

あとは、プログラムのどの部分で処理に時間がかかっているかを確認するために
ステップインを使うのが良いです。
EXCEL VBAであれば、CTRL + F8を実施して途中まで実行させることができます。
http://hp.vector.co.jp/authors/VA016119/step/step01.html

Comments

[退会済みユーザー]

アドバイス有難うございます。