最近急にVBAの処理速度が遅くなりました。

Question

こんにちは。以前こちらで横並びのデータを縦並びにしたいという質問に、VBAで解決して下さいました。
あの後順調にきていましたが、最近マクロを実行すると終わるまで15分ほどかかってしまいます。

以前教えていただいたコードはこちらです。

Sub Sample4() '//この行から
Dim i As Long, j As Long, cnt As Long, lastRow As Long, wS As Worksheet
 Set wS = Worksheets("仕入表")
With Worksheets("在庫表")
 '//E列で「在庫表」Sheetの最終行取得★
 lastRow = .Cells(Rows.Count, "E").End(xlUp).Row
 '//「在庫表」SheetにデータがあればD列2行目～I列最終行データを一旦消去
If lastRow > 1 Then
 Range(.Cells(2, "D"), .Cells(lastRow, "I")).ClearContents
 End If
 cnt = 1
 For i = 3 To wS.Cells(Rows.Count, "A").End(xlUp).Row '//「仕入表」Sheetの3行目～A列最終行まで
For j = 5 To wS.Cells(i, Columns.Count).End(xlToLeft).Column Step 2 '//E列～i行最終列まで2行毎★
 If wS.Cells(i, j) <> 0 Then '//画像で「0」が表示されているので「0」以外を追加★
 cnt = cnt + 1
 '//最初のデータ行のみ「仕入表」Sheetの日付をD列に表示★
 If j = 5 Then
 .Cells(cnt, "D") = wS.Cells(i, "A")
 End If
 .Cells(cnt, "E") = wS.Cells(i, "B") '//B列に「コード」を表示
.Cells(cnt, "F") = wS.Cells(i, "C") '//F列に「商品名」を表示
.Cells(cnt, "G") = wS.Cells(i, "D") '//G列に「下代」を表示
.Cells(cnt, "H") = wS.Cells(i, j) '//H列に「色」を表示
.Cells(cnt, "I") = wS.Cells(i, j + 1) '//I列に「数」を表示
End If
 Next j
 Next i
 '//最後にD列の表示形式（日付）を「在庫表」SheetのA3セルの書式に設定★
 .Range("D:D").NumberFormatLocal = wS.Range("A3").NumberFormatLocal
 End With
 End Sub '//この行まで

補足ですが、仕入表に入力した情報を在庫表に転記させたいという質問でした。
終わりの行から続きを入力する形でよいのですが、”在庫表」SheetにデータがあればD列2行目～I列最終行データを一旦消去”という処理が遅くさせてるということはありますか？


データが何千行にもなっています。
解決策があれば教えていただきたいです。よろしくお願いします。

poco_2 · Accepted Answer

No.7、12の者です。

>03/17 17:02の補足について

コードのコピペや追加・削除を繰り返すうちに、必要な部分を消してしまったのだと思います。
現在実行しているコードをUPしましょう。^^

WindFaller · Answer

#15の補足
画像ファイルで、感じを掴んでください。
基本的には、赤い四角で囲った所を入れるだけのスタイルです。
若干、私のものには違いはありますが、検査用のマクロですから、元のご質問に使ったままで良く、ほかはいじらなくてもよいです。
その下に、シートエラーチェッカーの補助マクロを貼り付けた、というようになっています。

WindFaller · Answer

こんにちは。

最初のご質問から、全部見直しました。意外にも早く終わりました。

結論からすると、エラー自体が入る可能性は、#12さんご指摘でも、私のもあるように、エラーは、マクロ内部からのものではなかったことが分かりました。

a.Value = b.Value 
で、これは、エラーが入る入れ物ではないというエラーです。

今のコードからも、私自身もコードを書いてみましたが、不可抗力のエラーを取り除くことは、内容のマクロコードが非常にわかりづらくなってしまいます。

そこで、私が考えだした方法ですが、仕入表のエラーチェックをする、「シートエラーチェッカー」をつけることにしました。もちろん、在庫表を同じようにしても構いません。マクロ自体を書き換えるにしても、一行を差し入れればすみます。

なお、こちらのマクロをお見せするかどうかは迷うところです。
コードの考え方も違いますが、見かけでひとつだけ違いがあるのは、将来、データベースなどに切り替えるときに、日付値が抜けているものはデータ化できませんので、日付値を入れて、それを白で隠す方法にしました。

'//
Sub Sample4() '//この行から
Dim i As Long, j As Long, cnt As Long, lastRow As Long, wS As Worksheet
Set wS = Worksheets("仕入表")

Call SheetErrChecker(wS)　'シートエラーチェッカー ●
With Worksheets("在庫表")
'//E列で「在庫表」Sheetの最終行取得★

・
・
・
End Sub

'同じ場所の下に貼り付けます。
'エラー値を削除してしまう、サブルーチン型マクロです。
Private Sub SheetErrChecker(ByRef sh As Worksheet)
Dim pErr As Range
With sh
On Error Resume Next
Set pErr = .UsedRange.SpecialCells(xlCellTypeConstants, 16)
If Not pErr Is Nothing Then
　　pErr.ClearContents
End If
Set pErr = .UsedRange.SpecialCells(xlCellTypeFormulas, 16)
If Not pErr Is Nothing Then
　　pErr.ClearContents
End If
On Error GoTo 0
End With
End Sub

WindFaller · Answer

できるできないはともかくとして、再度、全部を見直させていただいてよろしいでしょうか。

たぶん、この
「横並びのデータを条件付きで縦に転記させたい」
https://oshiete.goo.ne.jp/qa/8980328.html
2015/05/12 00:31

の分だと思います。期限は、来週の月曜日一杯までにさせてください。
元の作った方は、ここの常連の方で、私の作り方とはまったく違うもので、競合しあうことはありません。ただ、その後、いろいろ変わった部分がある場合には、もう手の届かないものになってしまうでしょうけれども。

よろしくお願いします。

WindFaller · Answer

#11の回答者です。
たいへんに申し訳ありません。

実際に、If wS.Cells(i, j) <> 0

IsNumeric は、「ws.Cells(i, j)が数値だったら」ではなく、数式のエラーが入っていると考えたのです。

IsNumeric は、数式のエラー値を持った時には、それを弾き、また、数字であることも検査するので、そのあとで、0 と比較していることで、そういうようなエラーチェック処理を考えたのです。

そして、もし、ws.Cells(i, j)この処理の範囲でエラーが出たら、それが判るような、On Error トラップを考えたわけです。途中で止まれば、その場所が判るわけです。

×　If IsError(ws.Cells(i, j).Address) = False Then
If IsError(ws.Cells(i, j)) Then　　'こちらの方が良い。
 msg = ws.Cells(i, j).Address　　'←このアドレス自体にエラーがあるかどうか。
 End If
 MsgBox Err.Number & ": " & Err.Description & vbCrLf & msg

しかし、そのようなOn Error トラップをつけても、そこには反応しなかったとなると、それを深追いするよりも原点に戻るべきかなとは思います。

それを直すには、その表の全体の作りの最初から、見ていかなくてはならないかもしれません。

poco_2 · Answer

No.7です。

WindFallerさんがNo.11で追加したコード
>If IsNumeric(ws.Cells(i, j)) Then
これは「ws.Cells(i, j)が数値だったら」という式です。
でもこのセルは色を示す文字列であって数値ではないのですよね。
なのでここで全てはじかれてしまい、データの転記がされていません。

>If IsNumeric(ws.Cells(i, j)) Then
を追加する前のコードで、質問者様が補足コメントにお書きになった
>エラー１３の表示が出たときにデバック？というボタンを押したらVBAのコードで
>以下の部分が黄色で色付けされていました。
>If wS.Cells(i, j) <> 0 Then '//画像で「0」が表示されているので「0」以外を追加★
については、仕入表のシートで式がエラーになっているためではないかと推測しますがいかがでしょうか？
そちらの式でエラーを出さないようにはできませんか？

WindFaller · Answer

エラーチェック版です。
'//
Sub Sample4er() '//この行から
  Dim i As Long, j As Long, cnt As Long, lastRow As Long, ws As Worksheet
  On Error GoTo ErrHandler
  Set ws = Worksheets("仕入表")
  With Worksheets("在庫表")
    ''//E列で「在庫表」Sheetの最終行取得★
    lastRow = .Cells(Rows.Count, "E").End(xlUp).Row
    ''//「在庫表」SheetにデータがあればD列2行目～I列最終行データを一旦消去
    If lastRow > 1 Then
      Range(.Cells(2, "D"), .Cells(lastRow, "I")).ClearContents
    End If
    cnt = 1
    For i = 3 To ws.Cells(Rows.Count, "A").End(xlUp).Row '//「仕入表」Sheetの3行目～A列最終行まで
      For j = 5 To ws.Cells(i, Columns.Count).End(xlToLeft).Column Step 2 '//E列～i行最終列まで2行毎★
        
        If IsNumeric(ws.Cells(i, j)) Then
          If ws.Cells(i, j) <> 0 Then '//画像で「0」が表示されているので「0」以外を追加★
            cnt = cnt + 1
            ''//最初のデータ行のみ「仕入表」Sheetの日付をD列に表示★
            If j = 5 Then
              .Cells(cnt, "D") = ws.Cells(i, "A")
            End If
            .Cells(cnt, "E") = ws.Cells(i, "B") '//B列に「コード」を表示
            .Cells(cnt, "F") = ws.Cells(i, "C") '//F列に「商品名」を表示
            .Cells(cnt, "G") = ws.Cells(i, "D") '//G列に「下代」を表示
            .Cells(cnt, "H") = ws.Cells(i, j) '//H列に「色」を表示
            .Cells(cnt, "I") = ws.Cells(i, j + 1) '//I列に「数」を表示
          End If
        End If
      Next j
    Next i
    '  //最後にD列の表示形式（日付）を「在庫表」SheetのA3セルの書式に設定★
    .Range("D:D").NumberFormatLocal = ws.Range("A3").NumberFormatLocal
  End With
  Exit Sub
ErrHandler:
Dim msg
  If IsError(ws.Cells(i, j).Address) = False Then
     msg = ws.Cells(i, j).Address
  End If
  MsgBox Err.Number & ": " & Err.Description & vbCrLf & msg
End Sub '//この行まで

WindFaller · Answer

#9の回答者です。

>実行の後に、「実行時エラー’１３　　　型が一致しません」
>と出てきました。これは何でしょうか・・・無視しても大丈夫ですか？

できれば、その場所を特定したいと思います。

On Error Resume Next でエラーは無視はできますが、
それでは、エラーは放置したままになってしまいます。
ふつう、期待される変数の型と代入の値の型とあっていないことが多いですね。

例えば、

Dim myVal As Date
myVal = DateValue("2017/3/32")
の場合に、そのようなエラーが出ます。
myVal = DateValue("2017/3/31") ならOKです。

次は、
ActiveCell には、エラーが出ている場合。
Dim myVal As Long
myVal = ActiveCell

'---------------------------------
今、コードをみましたが、いろいろなデータで、シュミレートしてみたところ、以下の部分で、エラー(13)が排出します。
シートの中がエラーが出ていなければ、本来エラーは出ないかもしれません。

前のコードから見直すべきなのか思案中です。

ここと決まっているわけではありませんが、あくまでも、こちらの想像の範囲です。
　If wS.Cells(i, j) <> 0 Then '//画像で「0」が表示されているので「0」以外を追加★

その対処法としては、例えば、
　If IsNumeric(wS.Cells(i, j)) Then　'←加える
　　If wS.Cells(i, j) <> 0 Then '//画像で「0」が表示されているので「0」以外を追加★

　　End If
　End if　　'←加える

WindFaller · Answer

こんにちは。

①
>'//最後にD列の表示形式（日付）を「在庫表」SheetのA3セルの書式に設定★
>.Range("D:D").NumberFormatLocal = wS.Range("A3").NumberFormatLocal

基本的なことですが、D:D 列全体のような使い方は、その組み合わせが複雑なほど、重くなってしまいます。

全列および全行の参照が良い場合とそうでない場合があります。組み込み関数などでは、行の最終セルまでですから、問題ありませんが、この場合は、まともに、最後の行まで書いてしまっていますから、ここはうまくありません。(これを書いた人には申し訳ないのですが、セルに書き込む場合は、無駄になってしまうし、重くなってしまうので、全行の参照はやめたほうがよいです)

このような方式に換えたほうがよいです。
 .Range("D1", Cells(Rows.Count, 4).End(xlUp)).NumberFormatLocal　=wS.Range("A3").NumberFormatLocal

ただし、例外はCells(全体のセル) に書き込む時だけは、問題が回避されます。

https://msdn.microsoft.com/ja-jp/library/office/ff726673
Excel 2010 のパフォーマンス: パフォーマンスの問題を最適化するヒント:全列および全行の参照

②
#7様が書かれている
Application.Calculation = xlCalculationManual
Application.ScreenUpdating = False
のくだりは必要です。

③
もうひとつは、VBAの場合は、設定によりますが、VBA Editor のツール--オプションで、コンパイルの方法を、順次コンパイル+「場合によって:バックグラウンド・コンパイル」にしておいたら変化するかどうか試してみる価値はあります。(変化しない場合も多いのですが)

④
VBAの高速化とは
「コードの実行中は必要な機能以外すべて無効にする」ということです。
それに加えて、セルへのアクセスを減らすことです。今は、細かいところまで見ていませんので、それについては、この程度にとどめておきます。

参考サイト：
「Excel 2010 のパフォーマンス: パフォーマンスの問題を最適化するヒント」
https://msdn.microsoft.com/ja-jp/library/office/ff726673#xlFasterVBA

tatsu99 · Answer

最速化してみました。
列のループは最大１０色ということなので、23列までループするようにしました。
色の値が０の時、列のループを打ち切るようにしました。
ロジック的に最速化できるのは、以上の項目のみです。
更新中の画面表示をしないようにしました。
これで改善しない場合は、他に原因があるかと。

Sub Sample4() '//この行から
    Dim i As Long, j As Long, cnt As Long, lastRow As Long, wS As Worksheet
    Set wS = Worksheets("仕入表")
    Application.ScreenUpdating = False
    With Worksheets("在庫表")
        '//E列で「在庫表」Sheetの最終行取得★
        lastRow = .Cells(Rows.Count, "E").End(xlUp).Row
        '//「在庫表」SheetにデータがあればD列2行目～I列最終行データを一旦消去
        If lastRow > 1 Then
            Range(.Cells(2, "D"), .Cells(lastRow, "I")).ClearContents
        End If
        cnt = 1
        For i = 3 To wS.Cells(Rows.Count, "A").End(xlUp).Row '//「仕入表」Sheetの3行目～A列最終行まで
            For j = 5 To 23 Step 2 '//E列～i行最終列まで2行毎★     '//////////goo修正
                If wS.Cells(i, j).Value = 0 Then Exit For           '//////////goo修正
                    cnt = cnt + 1
                    '//最初のデータ行のみ「仕入表」Sheetの日付をD列に表示★
                    If j = 5 Then
                        .Cells(cnt, "D") = wS.Cells(i, "A")
                    End If
                    .Cells(cnt, "E") = wS.Cells(i, "B") '//E列に「コード」を表示
                    .Cells(cnt, "F") = wS.Cells(i, "C") '//F列に「商品名」を表示
                    .Cells(cnt, "G") = wS.Cells(i, "D") '//G列に「下代」を表示
                    .Cells(cnt, "H") = wS.Cells(i, j) '//H列に「色」を表示
                    .Cells(cnt, "I") = wS.Cells(i, j + 1) '//I列に「数」を表示
            Next j
        Next i
        '//最後にD列の表示形式（日付）を「在庫表」SheetのA3セルの書式に設定★
        .Range("D:D").NumberFormatLocal = wS.Range("A3").NumberFormatLocal
    End With
    Application.ScreenUpdating = True
End Sub '//この行まで

最近急にVBAの処理速度が遅くなりました。

No.7、12の者です。

#15の補足

こんにちは。

できるできないはともかくとして、再度、全部を見直させていただいてよろしいでしょうか。

#11の回答者です。

No.7です。

エラーチェック版です。

#9の回答者です。

こんにちは。

最速化してみました。

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

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

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

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

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

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