質問をすることでしか得られない、回答やアドバイスがある。

15分調べてもわからないことは、質問しよう!

ただいまの
回答率

90.84%

  • VBA

    1464questions

    VBAはオブジェクト指向プログラミング言語のひとつで、マクロを作成によりExcelなどのOffice業務を自動化することができます。

  • Excel

    1267questions

    Excelは、マイクロソフト社が開発しているデータ集計や分析を行う表計算ソフトの一つです。文書作成や表計算、資料作成などの多彩な機能を備えており、統合パッケージであるMicrosoft Officeに含まれています。

VBA高速化

解決済

回答 3

投稿

  • 評価
  • クリップ 0
  • VIEW 521

pipi

score 139

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

ここで質問し、皆様のご協力の下、なんとか差分抽出マクロを完成させましたが、
実行してみると、すごく遅いです。処理が終わるまで、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

ご教授下さい。

  • 気になる質問をクリップする

    クリップした質問は、後からいつでもマイページで確認できます。

    またクリップした質問に回答があった際、通知やメールを受け取ることができます。

    クリップを取り消します

  • 良い質問の評価を上げる

    以下のような質問は評価を上げましょう

    • 質問内容が明確
    • 自分も答えを知りたい
    • 質問者以外のユーザにも役立つ

    評価が高い質問は、TOPページの「注目」タブのフィードに表示されやすくなります。

    質問の評価を上げたことを取り消します

  • 評価を下げられる数の上限に達しました

    評価を下げることができません

    • 1日5回まで評価を下げられます
    • 1日に1ユーザに対して2回まで評価を下げられます

    質問の評価を下げる

    teratailでは下記のような質問を「具体的に困っていることがない質問」、「サイトポリシーに違反する質問」と定義し、推奨していません。

    • プログラミングに関係のない質問
    • やってほしいことだけを記載した丸投げの質問
    • 問題・課題が含まれていない質問
    • 意図的に内容が抹消された質問
    • 広告と受け取られるような投稿

    評価が下がると、TOPページの「アクティブ」「注目」タブのフィードに表示されにくくなります。

    質問の評価を下げたことを取り消します

    この機能は開放されていません

    評価を下げる条件を満たしてません

    評価を下げる理由を選択してください

    詳細な説明はこちら

    上記に当てはまらず、質問内容が明確になっていない質問には「情報の追加・修正依頼」機能からコメントをしてください。

    質問の評価を下げる機能の利用条件

    この機能を利用するためには、以下の事項を行う必要があります。

質問への追記・修正、ベストアンサー選択の依頼

  • 退会済みユーザー

    2017/01/08 17:39

    こちらの質問が他のユーザから「やってほしいことだけを記載した丸投げの質問」という指摘を受けました
    「質問を編集する」ボタンから編集を行い、調査したこと・試したことを記入していただくと、回答が得られやすくなります。

回答 3

+2

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

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

投稿

  • 回答の評価を上げる

    以下のような回答は評価を上げましょう

    • 正しい回答
    • わかりやすい回答
    • ためになる回答

    評価が高い回答ほどページの上位に表示されます。

  • 回答の評価を下げる

    下記のような回答は推奨されていません。

    • 間違っている回答
    • 質問の回答になっていない投稿
    • スパムや攻撃的な表現を用いた投稿

    評価を下げる際はその理由を明確に伝え、適切な回答に修正してもらいましょう。

+2

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

さて、ステップインで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   '画面描写を再開

投稿

  • 回答の評価を上げる

    以下のような回答は評価を上げましょう

    • 正しい回答
    • わかりやすい回答
    • ためになる回答

    評価が高い回答ほどページの上位に表示されます。

  • 回答の評価を下げる

    下記のような回答は推奨されていません。

    • 間違っている回答
    • 質問の回答になっていない投稿
    • スパムや攻撃的な表現を用いた投稿

    評価を下げる際はその理由を明確に伝え、適切な回答に修正してもらいましょう。

  • 2017/01/09 18:11

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

    キャンセル

checkベストアンサー

+1

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

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

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

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

イコールの時に空白にするのではなく、異なるときに「X」を入れるようにする
(変更前)
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

投稿

  • 回答の評価を上げる

    以下のような回答は評価を上げましょう

    • 正しい回答
    • わかりやすい回答
    • ためになる回答

    評価が高い回答ほどページの上位に表示されます。

  • 回答の評価を下げる

    下記のような回答は推奨されていません。

    • 間違っている回答
    • 質問の回答になっていない投稿
    • スパムや攻撃的な表現を用いた投稿

    評価を下げる際はその理由を明確に伝え、適切な回答に修正してもらいましょう。

  • 2017/01/09 18:11

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

    キャンセル

15分調べてもわからないことは、teratailで質問しよう!

  • ただいまの回答率 90.84%
  • 質問をまとめることで、思考を整理して素早く解決
  • テンプレート機能で、簡単に質問をまとめられる

関連した質問

同じタグがついた質問を見る

  • VBA

    1464questions

    VBAはオブジェクト指向プログラミング言語のひとつで、マクロを作成によりExcelなどのOffice業務を自動化することができます。

  • Excel

    1267questions

    Excelは、マイクロソフト社が開発しているデータ集計や分析を行う表計算ソフトの一つです。文書作成や表計算、資料作成などの多彩な機能を備えており、統合パッケージであるMicrosoft Officeに含まれています。