Excel (VBA)

Excel VBAに関するフォーラムです。
  • 掲示板への投稿には会員登録(無料)が必要です。会員登録がまだの方はこちら
  • 掲示板ご利用上のお願い」に反するご記入はご遠慮ください。
  • Q&A掲示板の使い方はこちらをご覧ください
トピックに返信
質問

 
(Windows 10 Home : Microsoft 365)
大したVBA処理でもないのに遅くなってしまいます
投稿日時: 22/09/02 17:52:19
投稿者: SURT

ある売上データを連続で入力します
個数を入力したときに日付欄や担当者IDが空欄なら上の値をコピペするようにしていて
テーブル化したセルに入力するたびに下に単価計算用のセルなどとともに追加されていきます
 
以下のように書いたのですが動作が非常に遅いです
10件ほど連続で個数だけ入力すると、終わったあとに時間差でまだ描画が続いています
 
Private Sub Worksheet_Change(ByVal Target As Range)
    With Target
     
        '個数を入力する列数を定義
        If .Column <> 8 Or .Row = 1 Then Exit Sub
          
        '日付(個数からのオフセット距離)が空欄なら
        If .Offset(, -1).Value = "" Then
            '日付をコピー
            .Offset(, -1).Value = .Offset(-1, -1).Value
            '担当者IDが空欄なら上の行の担当者IDをコピー
            If .Offset(, 1).Value = "" Then .Offset(, 1).Value = .Offset(-1, 1).Value
 
        End If
         
    End With
     
End Sub
 
記述になにか問題があるでしょうか?
他のシートにテーブルを作りVBAなして入力すると列は時間差なく追加、描画されます

投稿日時: 22/09/02 17:58:37
投稿者: SURT

追記です
 
どうやら新たに入力したセルには書式も適応されていないようです
 
テーブル以外の背景を灰色にしてテーブルのみを白くしていますが
入力されたものは灰色のままで、開き直すと書式が適応されて白になっています
直接日付を入力した行は入力時(テーブルに追加されたときに)白くなります

回答
投稿日時: 22/09/02 18:22:47
投稿者: taitani
投稿者のウェブサイトに移動

・マクロVBAの高速化・速度対策の具体的手順と検証
https://excel-ubara.com/excelvba4/EXCEL228.html
 
この辺の"Application.ScreenUpdatingの停止"と"Application.Calculationを手動"を参考にしてみてください。

回答
投稿日時: 22/09/02 19:15:49
投稿者: simple

changeイベントプロシージャーの中でセルを変更すると、
それがまたChangeイベントプロシージャを実行させ、と
連鎖が起きています。
幸い8列目以外なら直ぐに抜けるので問題はないように見受けますが、
無駄は無駄かもしれません。
Application.EnableEventsなどを調べられると良いと思います。
 
提示されているものがコードのすべてでしょうか。
ほかにイベントプロシージャがあるとか、省略されているコードはありませんか?

回答
投稿日時: 22/09/02 20:24:28
投稿者: WinArrow
投稿者のウェブサイトに移動

揮発性関数を使っていませんか?
 
揮発性関数が使われていると、入力の都度、全計算式が再計算されます。

回答
投稿日時: 22/09/02 21:40:37
投稿者: simple

それでは、既に指摘がありましたが、
マクロの最初で

    Application.Calculation = xlCalculationManual
とし、最後に
    Application.Calculation = xlCalculationAutomatic
としてみてはいかがですか?

投稿日時: 22/09/15 18:42:50
投稿者: SURT

様々な回答ありがとうございます
返事が遅くなりました
 
コードは質問文に書いたものがすべてで、
 
=IF(H3>0,(H3-1)*50+300,"")
 
として単価計算しているセルがある以外は計算式もありません
 
マクロの最初で
    Application.Calculation = xlCalculationManual
とし、最後に
    Application.Calculation = xlCalculationAutomatic
としてみてはいかがですか?
 
とするといいとの回答をもらってやってみましたが
20個ほどバババッと入力すると遅延して入力されていきます
VBAを無効にすると遅延することがありませんので
記述がまずく著しい速度低下をしているのではないかと思っていますがどうでしょうか
 
追記に書いていた書式の問題に関しては、先程入力したらなぜか発生しなくなっていました

回答
投稿日時: 22/09/15 20:24:15
投稿者: simple

繰り返しになりますが、下記でも同様の動作遅延が起きますか?

Private Sub Worksheet_Change(ByVal Target As Range)
    With Target
       If .Column <> 8 Or .Row = 1 Then Exit Sub
        If .Offset(, -1).Value = "" Then
            Application.EnableEvents = False
            Application.Calculation = xlCalculationManual
            .Offset(, -1).Value = .Offset(-1, -1).Value
            If .Offset(, 1).Value = "" Then .Offset(, 1).Value = .Offset(-1, 1).Value
            Application.EnableEvents = True
            Application.Calculation = xlCalculationAutomatic
        End If
    End With
End Sub
これでも遅延とすれば、ファイル自体になんらかの異常が発生しているくらいしか、
考えつきませんね。
まったく新しいブックに、データを移して同じ事象が発生するか確認されたらいかがですか?
(データは、できればテキストエディターなどにいったんコピーして、直接コピーしないほうが
  良いと思います。異常の原因自体がコピーされる恐れがあるので。
  式は、再度入力してください。)

投稿日時: 22/09/16 19:06:45
投稿者: SURT

書いていただいたコードでも遅延しました(わずかに速くなったように感じました)
ファイルに問題があるのではないかとのご指摘をうけて
新規につくりなおしたところ、自前のコードでもサクサクでした
 
検証したところどうやらレコード数(行数)が多すぎるのが問題だったようです
現時点で5万行ほどです
 
ByVal Target As Range
は全体を選択するから重たくなるのでしょうか?
解決策はありますか?

回答
投稿日時: 22/09/16 21:47:38
投稿者: simple

引用:
新規につくりなおしたところ、自前のコードでもサクサクでした

なんらかの状況(書式が多数ある等々)で、ブックが不安定になっていたものと想像されます。
その原因はMS社以外の第三者には分かりません。想像するのみです。
 
引用:
ByVal Target As Range
は全体を選択するから重たくなるのでしょうか?
解決策はありますか?
おっしゃる意味が分かりません。
Targetというのは変化が生じたセルですから、全体を選択している訳ではありません。
コード自体には特段の問題はなかったのでは?
 
ブックが不安定になっていたことが最大の原因と考えられますから、
それを解消することが「解決策」であり、それは果たされたのではないんですか?

投稿日時: 22/09/18 18:02:40
投稿者: SURT

伝え方が悪くてすみません
新たに作っても5万行ほどになると遅延します
新たに作らなくても100行程度なら遅延しません
 
つまりコードのどこかに行数が増えると重たくなってしまう部分があると思うのですが
私の力量ではそのような箇所があるようにも思えません
 
なので、詳しい方に問題の箇所を指摘していただきたくて質問しました

回答
投稿日時: 22/09/18 19:31:26
投稿者: simple

念のため5万行のテーブルを作ってやってみましたが、遅延はありませんでした。
(Excel2019,Win10)
なにかしら提示されていない要因があるのではないかと思います。
 
詳しい方からのコメントをお待ちください。

投稿日時: 22/09/20 15:27:12
投稿者: SURT

記載したコードと
=IF(H3>0,(H3-1)*50+300,"")
がすべての行にあるだけです
 
最初の質問時にも書きましたが
あといじったところといえばテーブル化している程度です
 
i7 4790k
でメモリ16GB
さらにSSDなのでPCの問題でもなさそうです

投稿日時: 22/09/20 15:39:59
投稿者: SURT

アニメーションが原因かとおもいオフにしましたが変化なし
 
もしかしたら単純に入力が速すぎて追いついていないだけなのかもしれません
 
https://www.youtube.com/watch?v=LHph9PR9GAY
くらいの速度で30列ほど連続してやってます(紙をみて入力しているので紙が変わるから)
 
30行ほど連続していれると、終わったあとに10行ほど遅れて順番に入力されていくのを
眺めることになります

回答
投稿日時: 22/09/20 15:42:04
投稿者: taitani
投稿者のウェブサイトに移動

気になったので私も動作テストしました。
 
OS:Windows 10
プロセッサ:i5
メモリ:16G
 
データ5万 (A列〜H列)
I列に「=IF(H2>0,(H2-1)*50+300,"")」
 
Code は質問と同じ。
描画遅延無しで、秒で完了しました。

回答
投稿日時: 22/09/20 15:44:06
投稿者: taitani
投稿者のウェブサイトに移動

そもそも、
 
"30行ほど連続していれると"
 
が、まとめて値で貼り付けなら、Target と Offset でエラーになると思われ。

投稿日時: 22/09/20 15:48:25
投稿者: SURT

先程貼った動画のようにテンキーで手入力で入力しています
 
行数を減らしてみたところ遅延は発生しませんでしたが
300行を超えたあたりからだんだんと遅くなっくるようでした
100行程度ではキー入力と同時にセルに表示されるのに
段々とそれが遅くなっていくようです

投稿日時: 22/09/20 15:51:45
投稿者: SURT

ちなみに、計算式を空欄にしても動作にかわりはありませんでした
行数のみが影響をあたえているようです
 
テーブル機能も問題なのかもしれません

回答
投稿日時: 22/09/20 16:11:11
投稿者: taitani
投稿者のウェブサイトに移動

すみません、入れ違いでしたね。
あと、YouTube が見れる環境に居ないので、見れていません。ごめんなさい。
 
切り分けになるかどうかわかりませんが、
以下の Code ではいかがでしょうか。
 

Private Sub Worksheet_Change(ByVal Target As Range)
    '個数を入力する列数を定義
    If Target.Column = 8 Or Target.Row <> 1 Then
        With Target
            '日付(個数からのオフセット距離)が空欄なら
            If .Offset(, -1).Value = "" Then
                Application.EnableEvents = False
                Application.Calculation = xlCalculationManual
                '日付をコピー
                .Offset(, -1).Value = .Offset(-1, -1).Value
                '担当者IDが空欄なら上の行の担当者IDをコピー
                If .Offset(, 1).Value = "" Then .Offset(, 1).Value = .Offset(-1, 1).Value
                Application.EnableEvents = True
                Application.Calculation = xlCalculationAutomatic
            End If
        End With
    End If
End Sub

 
※ simple さんの Code で、Target 判断を前にしただけです。

投稿日時: 22/09/20 20:04:57
投稿者: SURT

差は感じられませんでした
 
色々やってみましたがテーブルを解除すると遅延はなくなるようです
行数が多すぎるテーブルが問題なのかもしれません
テーブルの最終行直後に入力すると自動で拡張されますが、それが行数が多いともたついているのではないあと思います
(行数が少ないとテーブルでも問題ない)
VBAにあまり詳しくないのでコードに問題があると思い込んでおりましたが
多分上記の問題だと思います
 
迂回作として計算セルもVBAで追加していく処理にしようとと思います

回答
投稿日時: 22/09/21 10:44:13
投稿者: WinArrow
投稿者のウェブサイトに移動

Excelのテーブル機能には、
裏にデータベースを持っていて、セルにデータが入力(更新)されると
データベースを更新して
データベースから、セルに表示していると
思います。
データベースからセルに表示する際、
全件なのか、更新のあったデータのみなのか?
わかりませんが、
>次第に遅くなる
ということから推測すると、全件なのかな?と思われます。(外しているかも?)
 
ListObjectを使った方法に切り替えるなど、別方法を検討してみたら如何でしょう。

回答
投稿日時: 22/09/22 19:12:17
投稿者: WinArrow
投稿者のウェブサイトに移動

ListObjectを利用した例
 
入力セルは、J1 にしています。リストの範囲外ならば、何処でもよい
 

Private Sub Worksheet_Change(ByVal Target As Range)
Dim ListOBJ As ListObject, N As Long
    
    If Target.Address(0, 0) = "J1" Then
        Application.EnableEvents = False
        Set ListOBJ = Me.ListObjects(1)
        ListOBJ.ListRows.Add
        N = ListOBJ.Range.Rows.Count
        ListOBJ.ListRows(N - 1).Range(1) = Target.Value
        If ListOBJ.ListRows(N - 1).Range(1) = "" Then
            ListOBJ.ListRows(N - 1).Range(1) = ListOBJ.ListRows(N - 2).Range(1)
        End If
        Application.EnableEvents = True
    End If
    
End Sub

回答
投稿日時: 22/09/23 13:47:15
投稿者: WinArrow
投稿者のウェブサイトに移動

ちょっとした疑問
  
コードから
  
G列が日付
H列が個数
I列が担当者ID
といったレイアウトと思われます。
Worksheet_ChangeイベントはH列の個数入力時に発生することになっています。
  
通常、項目入力は、左から右へ入力すると思いますが、
このイベントは、I列入力前に発生しますから、I列は当然未入力ですよね?
I列未入力時は、前行セルの値を転記する補正コードとなっていますが、
G列未入力の時しかI列セルの補正は行われません。
操作を含めて、この仕様でよいのでしょうか?
もう一つ、個数セルを空白にした場合もこのイベントは発生します。
掲示のコードでは、何も処理されずに終了するが、問題ないのですか?
  
  
それと
>=IF(H3>0,(H3-1)*50+300,"")
この数式が入力されている列も気になります。

投稿日時: 22/09/24 14:55:14
投稿者: SURT

WinArrowさんコードありがとうございます
 
はじめに一度日付を入力して個数と担当者IDをいれます
あとは個数だけを入力していけば
上のセルの日付とIDがコピーされていく仕組みです
 
テーブルに個数をいれると上記の動作をしたあと
テーブル直下の個数にカーソルが来るのでまた個数をいれる感じです
日付が変わるときには左キーで日付にいき日付を入力したあと個数をいれます
 
個数や日付のみ訂正したときにIDが変わらないように未入力のときだけ発生するようにしています
 
個数を入れてはじめて機能するような仕組みで問題はないです
(このExcel自体が、単純に個数と担当者の記録をとるだけなので)
 
詳しい方からみたら、やりたいことに対して回りくどい処理などがあり
疑問に思われるところがあるかもしれません
 
単純にいうと、個数だけ入力したら上のセルの日付とIDをコピペ
ができればいいです

回答
投稿日時: 22/09/24 15:31:53
投稿者: WinArrow
投稿者のウェブサイトに移動

VBAでListObjectを使って入力するには、
直接テーブルに入力するのではなく、別の領域(セル)に1件だけ入力し、そのデータをテーブルに転記する方法を考えました。
 
この方法で処理時間を比較することで、
ListObjectが有効か?判断できます。
 
「別の領域(セル)に1件だけ入力し」:この段階では、
日付、担当ID、個数
といったレイアウトが必要になると考えます。
LISTOBJECTに転記する時は順序を間違えないようにします。

回答
投稿日時: 22/09/24 21:49:13
投稿者: WinArrow
投稿者のウェブサイトに移動

私がListObjectを推奨する理由
  
Office TANAKAさんのページに、
VBAで、テーブル機能に切り替えたデータを、
テーブル機能ではない(通常操作)方法でアクセスすると、
意図したように動かないことがある。・・・らしい。
  
↓URLです。
http://officetanaka.net/excel/vba/table/
  
従って、ListObject(テーブル機能)にアクセスする方法を
試してみたら・・・・という提案をしているわけです。
 

回答
投稿日時: 22/09/27 17:08:49
投稿者: mattuwan44

原因はよくわかりませんが。。。。
 
提案1)
マクロを使っているのだから、シートに計算式を置かないようにして、
マクロで計算結果を入力するようにしてみては?
よくわからないけども、数式の再計算に時間がかかっている気がします。。。
 
提案2)
マクロを使わなくても、
Ctrlキー + Dキー
で、上のセルをコピーできます。

回答
投稿日時: 22/09/29 10:47:47
投稿者: WinArrow
投稿者のウェブサイトに移動

そもそも・・・テーブル化した目的は、何でしょう?
「数式を自動複写したい」が目的ならば、
VBAでならば、非テーブル化した表に対して、一括で数式代入可能です。
 
前レスにも書きましたが、
テーブル化した表をVBAで取扱うには、それなりのリスクがとなうことを認識する必要がある。
 
説明の数式のためだけに、テーブル化したのであれば、
一旦、テーブルを外して、掲示のプロシジャを実行することもありと思います。
テーブル化は本当に必要ですか?
 
 
 

回答
投稿日時: 22/09/30 11:44:04
投稿者: simple

以下のとおり実験してみました。
参考にしていただきたく思います。
 
■イベント処理ではなく、一括処理として、同様の処理を
(1)テーブルを使用しない
(2)テーブルを使用する (セル操作には、ListObjectを利用しない。)
(3)テーブルを使用する (セル操作には、ListObjectを利用する。)
の3つの方法で実行して、時間を計測しました。。
 
■処理内容は概略次のとおりです。
・A1から始まる縦50000行、横9列のセル範囲を対象とする。
・45000行までは
    7列目に日付をいれ、9列目に担当者コードを入れます。
・45001行目以降の5000行に対して、
    日付、担当者コードに関して、前行のデータを増幅する処理としました。
・なお、6列目までについては、50000行までダミーの数式を入れてあります。
 
■結果

(1)  0.3828125秒   テーブルなし
(2)  0.5585938秒   テーブルあり
(3)  0.5507813秒   ListObject利用

もう一回
(1)  0.375    秒   テーブルなし
(2)  0.5703125秒   テーブルあり
(3)  0.5429688秒   ListObject利用
となりました。解釈は皆さまにお任せいたします。
 
入力は、テーブルなしの状態で行い、データ入力後にテーブル化してから、
PowerQuery等を使ってデータ操作するのが、今どきかもしれませんね。
 
 
以下参考までに使用したコードを載せておきます。
Dim ws As Worksheet
Dim myRange As Range
Sub Table利用せず()
    Dim k&
    Dim t
    Set ws = Sheet1
    Set myRange = ws.[A1].Resize(50000, 9)

    Application.ScreenUpdating = False
    Application.Calculation = xlCalculationManual
    
    Call 初期設定
    With ws
        t = Timer   ' ここ以降の実行時間を測定
        For k = 45001 To 50000
            If .Cells(k, 7).Value = "" Then
                .Cells(k, 7).Value = .Cells(k - 1, 7).Value
                If .Cells(k, 9).Value = "" Then
                    .Cells(k, 9).Value = .Cells(k - 1, 9).Value
                End If
            End If
        Next
    End With
    Application.ScreenUpdating = True
    Application.Calculation = xlCalculationAutomatic
    Debug.Print Timer - t; " テーブルなし"
End Sub

Sub Table利用()
    Dim k&
    Dim t

    Set ws = Sheet1
    Set myRange = ws.[A1].Resize(50000, 9)
    Application.ScreenUpdating = False
    Application.Calculation = xlCalculationManual

    Call 初期設定

    With ws
        .ListObjects.Add(xlSrcRange, myRange, , xlYes).Name = "テーブル1"

        t = Timer
        For k = 45001 To 50000
            If .Cells(k, 7).Value = "" Then
                .Cells(k, 7).Value = .Cells(k - 1, 7).Value
                If .Cells(k, 9).Value = "" Then
                    .Cells(k, 9).Value = .Cells(k - 1, 9).Value
                End If
            End If
        Next
    End With
    Application.ScreenUpdating = True
    Application.Calculation = xlCalculationAutomatic
    Debug.Print Timer - t; " テーブルあり"
End Sub

Sub ListObject利用()
    Dim listObj As ListObject
    Dim k&
    Dim t

    Set ws = Sheet1
    Set myRange = ws.[A1].Resize(50000, 9)
    Application.ScreenUpdating = False
    Application.Calculation = xlCalculationManual

    Call 初期設定
    With ws
        .ListObjects.Add(xlSrcRange, myRange, , xlYes).Name = "テーブル1"
        Set listObj = .ListObjects("テーブル1")

        t = Timer   ' ここ以降の実行時間を測定
        For k = 45001 To 50000
            If listObj.ListRows(k - 1).Range(7) = "" Then
                listObj.ListRows(k - 1).Range(7) = listObj.ListRows(k - 2).Range(7)
                If listObj.ListRows(k - 1).Range(9) = "" Then
                  listObj.ListRows(k - 1).Range(9) = listObj.ListRows(k - 2).Range(9)
                End If
            End If
        Next
    End With
    Application.ScreenUpdating = True
    Application.Calculation = xlCalculationAutomatic
    Debug.Print Timer - t; " ListObject利用"
End Sub

Function 初期設定()
    myRange.ClearContents
    On Error Resume Next
    If ws.ListObjects.Count > 0 Then
        ws.ListObjects(1).Delete
    End If
    On Error GoTo 0

    'ダミーデータをセット
    ws.[A1].Resize(50000, 6).Formula = "=row() & ""_"" & column()"
    ws.[G1:G45000] = DateSerial(2022, 10, 1)
    ws.[I1:I45000] = "A100"
End Function

回答
投稿日時: 22/09/30 17:01:15
投稿者: WinArrow
投稿者のウェブサイトに移動

simpleさん、コード作成ご苦労様です。
 
掲示のコードをこちらでも実行してみました。
テーブル化した場合、1行目に項目行が無いと、「応答なし」になってしまうので、
1行目を項目行に変更しました。
ことらのテスト結果は、次の通りです。
 
 1.171875 テーブルなし
 1.40625 テーブルあり
 1.40625 ListObject利用
 
テーブル化する時点で、テーブル化領域を50000行と全部指定しているので、
少し条件が違うと思います。
 
45000行でテーブル化してから、1件づつテーブル領域を追加する方法の方が
テーブルなしと比較できると思います。
 
ちょっと時間がないので、後でテストしてみます。

回答
投稿日時: 22/10/01 09:57:28
投稿者: simple

ご指摘のとおりですね。
テーブルにデータを追加していくところで時間を食いますね。
ただそれは手作業でやっても、同じことなので、
質問者さんの疑問にどこまで応えることになるのか、ちょっと整理がついていません。

回答
投稿日時: 22/10/01 14:58:55
投稿者: WinArrow
投稿者のウェブサイトに移動

いろいろテストしたところ
 
LISTOBJECTのデータ追加で、連続処理には向いていないような気がしますう。
 
行追加(データ追加ではない)には、2つの方法があることが分かりました。
Listobjects("AAA").ListRows.Add

Listobjects("AAA").Reize
です。
Addは1行だけ追加、Resieeは、複数行追加できます。
このとき、数式セルは、自動複写されます。
 
複数行の追加が分かっているとき
AddよりもResizeの方が時間が掛からないようです。
 
 
 

回答
投稿日時: 22/10/01 15:14:20
投稿者: simple

以下のコードを実行すると、
    473.1328 テーブルあり
つまり、8分弱かかってしまいました。
テーブルなしだと1秒かからないので、驚きです。
 
# まあ5万行も手作業で入力する気にはならないですけどねえ。
 

Sub Table利用()
    Dim k&
    Dim t

    Set ws = Sheet1
    Set myRange = ws.[A1].Resize(45000, 9)
    Application.ScreenUpdating = False
    Application.Calculation = xlCalculationManual
    Call 初期設定
    With ws
        .ListObjects.Add(xlSrcRange, myRange, , xlYes).Name = "テーブル1"
        t = Timer
        For k = 45001 To 50000
            If .Cells(k, 7).Value = "" Then
                .Cells(k, 7).Value = .Cells(k - 1, 7).Value
                If .Cells(k, 9).Value = "" Then
                    .Cells(k, 9).Value = .Cells(k - 1, 9).Value
                End If
            End If
        Next
    End With
    Application.ScreenUpdating = True
    Application.Calculation = xlCalculationAutomatic
    Debug.Print Timer - t; " テーブルあり"
End Sub
Function 初期設定()
    ws.[A1].Resize(50000, 9).ClearContents
    On Error Resume Next
    If ws.ListObjects.Count > 0 Then
        ws.ListObjects(1).Delete
    End If
    On Error GoTo 0

    'ダミーデータをセット
    ws.[A1].Resize(45000, 6).Formula = "=row() & ""_"" & column()"
    ws.[G1:G45000] = DateSerial(2022, 10, 1)
    ws.[I1:I45000] = "A100"
End Function

トピックに返信