ＶＢＡの基本について重くなる・・・

Question

こんばんは。皆様からの知恵をお借りして、なんとか自力で作ってみて、まためぐみんさまからの情報を頂戴して、粗削りですが、なんとか構文を組んでみました。
　確かに動きます。ですが、こなきじじぃが憑りついたかのごとく、応答がありませんを繰り返します。。めぐみんさまからの情報で、制御構文を入れてもやはりこなきじじぃはどっかにいってくれません。。
　以下に構文をそのまま貼り付けさせて頂きます。何回も回しているのでしょうか、、
Private Sub Worksheet_Change(ByVal Target As Range)

空白セルなら緑色で、数字が入れば、無地になるようにと作ってみました。
Dim i As Integer

 Dim j As Integer
 

Application.ScreenUpdating = False

For i = 4 To 15
 
 For j = 1 To 30

  
  
    If Range("S2") <= 10 And Cells(9, i) = "" Then Cells(9, i).Interior.ColorIndex = 10
     
     If Cells(9, i) = j Then Cells(9, i).Interior.ColorIndex = xlnon
    
    
    If Range("S2") <= 10 And Cells(6, i) = "" Then Cells(6, i).Interior.ColorIndex = 10
    
     If Cells(6, i) = j Then Cells(6, i).Interior.ColorIndex = xlnon
     
     
    If Range("S2") <= 10 And Cells(3, i) = "" Then Cells(3, i).Interior.ColorIndex = 10
       
       If Cells(3, i) = j Then Cells(3, i).Interior.ColorIndex = xlnon

Application.ScreenUpdating = True
Next
 Next
 
End Sub

貼り付けまでしようと思ったのですが、これ単体でも結構重かったので、途中でやめました。
制御構文入れても少しましになるぐらいです、、
Sub 回転数_ボタン1_Click()

Dim myrange As range

 

  Dim i As Integer
  
      For Each myrange In Sheets("回転数").range("A3:AL21")
     
       If myrange > 0 Then myrange.Copy
      

Next
 

End Sub

　対処方法などありますででしょうか、、それとも限界でしょうか、、それほど回しているとも思えず、、いつもお願いだけして申し訳ありませんが、お願いさせてたいだきたく存じ上げます。

tom04 · Accepted Answer

こんばんは！お示しのコードの＞For j = 1 To 30 は何のためのループかが不明ですが、もしかして、１～30までループさせ、その値とセル値が同じであればそのセルの色をなしにしたい！というコトでしょうか？そうであれば１以上30以下という条件だけで対応できると思います。尚、お示しのコードはChangeイベントのようなので、対象セルを指定していない限りどこのセルが変化してもマクロが実行され、余計なループをしているために遅く感じるのだと思います。 Changeイベントの場合は対象セルを限定した方が良いと思います。一例です。 Private Sub Worksheet_Change(ByVal Target As Range) 　Dim c As Range 　Dim myRng As Range 　　'//▼対象セル以外の場合は何もしない// 　　If Intersect(Target, Range("S2,D3:O3,D6:O6,D9:O9")) Is Nothing Or Target.Count > 1 Then Exit Sub 　　If Range("S2") > 10 Then Exit Sub '//S2セルが10より大きい場合は何もしない// 　　　With Target 　　　　If .Row = 2 Then '//←変化セルがS2の場合// 　　　　　Set myRng = Range("D3:O3,D6:O6,D9:O9") 　　　　　　For Each c In myRng '//←myRng　の範囲内だけをループ// 　　　　　　　If IsNumeric(c) And c Mod 1 = 0 Then '//←対象セルが数値で正数の場合①// 　　　　　　　　If c >= 1 And c <= 30 Then '//←対象セルが1以上30以下の場合②// 　　　　　　　　　c.Interior.ColorIndex = xlNone 　　　　　　　　Else 　　　　　　　　　c.Interior.ColorIndex = 10 　　　　　　　　End If 　　　　　　　End If 　　　　　　Next c 　　　　Else '//←変化セルがD～O列の3・6・9行目の場合// 　　　　　If IsNumeric(.Value) And .Value Mod 1 = 0 Then '//←上記コードの①// 　　　　　　If .Value >= 1 And .Value <= 30 Then '//←上記コードの②// 　　　　　　　.Interior.ColorIndex = xlNone 　　　　　　Else 　　　　　　　.Interior.ColorIndex = 10 　　　　　　End If 　　　　　End If 　　　　End If 　　　End With End Sub こんな感じではどうでしょうか？m(_ _)m

Qchan1962 · Answer

こんばんは、
実行コードを教えてもらってやり方がなんとなく分かり、
次の処理を教えてもらって、継ぎ足して、、、
それで覚えられるほど、簡単ではないと思います。
少し急ぎすぎでは、無いでしょうか。
処理の流れなどを確認する為にデバッグ方法を学習、検証する事を勧めます。（2回目）
ステップ実行で確認するだけでどこに時間がかかっているか概ねわかりますし、
過去のエラーも自己解決出来た可能性が高いです。

本題、既に皆さんから的確なアドバイスがありますが、
たったこれだけの処理で、重たいのは、様々の要因が想像できます。
PCのスペックなどもです。
継ぎ足しのVBAであるなら、BOOKを整理した方が良いと思います。

基本的に＃６さんの提案に賛成ですが、

下記にサンプルを書きます。
原因がどこにあるか分かりませんが、どうでしょう。

Private Sub Worksheet_Change(ByVal Target As Range)
Dim c As Range
Dim Rng10 As Range, RngNo As Range
　　If Intersect(Target, Range("S2,D3:O3,D6:O6,D9:O9")) Is Nothing _
　　　Or Target.Count > 1 Then Exit Sub
　　With Target
　　　　For Each c In Range("D3:O3,D6:O6,D9:O9")
　　　　　　If IsNumeric(c) And Int(c) = c Then
　　　　　　　　If c >= 1 And c <= 30 Then
　　　　　　　　　　If RngNo Is Nothing Then
　　　　　　　　　　　　Set RngNo = c
　　　　　　　　　　Else
　　　　　　　　　　　　Set RngNo = Union(RngNo, c)
　　　　　　　　　　End If
　　　　　　　　Else
　　　　　　　　　　If Rng10 Is Nothing Then
　　　　　　　　　　　　Set Rng10 = c
　　　　　　　　　　Else
　　　　　　　　　　　　Set Rng10 = Union(Rng10, c)
　　　　　　　　　　End If
　　　　　　　　End If
　　　　　　Else
　　　　　　　　If Rng10 Is Nothing Then
　　　　　　　　　　Set Rng10 = c
　　　　　　　　Else
　　　　　　　　　　Set Rng10 = Union(Rng10, c)
　　　　　　　　End If
　　　　　　End If
　　　　Next c
　　End With

Application.EnableEvents = False
　　Application.ScreenUpdating = False
　　Application.Calculation = xlCalculationManual

If Not RngNo Is Nothing Then RngNo.Interior.ColorIndex = xlNone
　　If Not Rng10 Is Nothing Then Rng10.Interior.ColorIndex = 10

' If Not Intersect(Target, Range("????")) Is Nothing
　　'　　Dim myrange As Range
　　'　　Dim i As Integer
　　'　　For Each myrange In Sheets("回転数").Range("A3:AL21")
　　'　　　　If myrange > 0 Then ??? .Value = myrange.Value
　　'　　Next
　　'　End If

Application.Calculation = xlCalculationAutomatic
　　Application.ScreenUpdating = True
　　Application.EnableEvents = True
End Sub

ママチャリ · Answer

>限界でしょうか。
ロジックが悪いだけでしょ。
コードを見ても何をしたいのか理解できませんもの。
たぶん、ものすごく無駄なことをやっているからだと思います。
また、Worksheet_Changeイベントプロシジャに書いている理由も理解できません。
（この前の私の回答が原因ですか？ぶっ飛んでるって言ったのに・・・）

理解できないコードを提示するより、何がしたいのか、正確に漏れなく、文章で説明した方が、解決の近道のような気がします。

fujillin · Answer

こんばんは

既に適切な回答が出ていますので、直接の回答ではありませんが・・・

セルの色を条件によって変えているだけのようですので、結果を得るだけであれば「条件付き書式」を設定しておけばすみそうに思います。

VBAの練習をなさっていらっしゃるのかもしれませんが、VBAで行うにしても、全く別の考え方として、「VBAから条件付き書式を設定する」という方法も考えられます。
この方法だと、一度だけVBAを実行しておけばよいことになりますね。

tom04 · Answer

No.3です。

投稿後気づきました。
VBAでの小数点以下を判断する「Mod」関数の扱いは結構難しいので、
とりあえず、各セルには整数しか入らないという前提にしてください。

前回のコードの
＞If IsNumeric(c) And c Mod 1 = 0 Then '//←対象セルが数値で正数の場合①//
（↑　「整数」を誤変換していましたね）
を単純に
＞If IsNumeric(c) Then 
に

そして
＞If IsNumeric(.Value) And .Value Mod 1 = 0 Then '//←上記コードの①//
は
＞If IsNumeric(.Value) Then 
だけに変更してみてください。

※　前回のコードではD～O列の対象セルが小数点以下のデータでも
変化してしまいます。m(_ _)m

うぱc · Answer

プログラムの始まりに
Application.ScreenUpdating = False

プログラムの終わりに

Application.ScreenUpdating = True

って入れてください

これで神がかります

うぱc · Answer

あー、ありますよ
超簡単な方法が

プログラムの始まりと終わりに一行ブッコムだけで100倍ぐらい早くなります

詳細忘れました
たしか　vba 高速化　か何かで出てくるライブラリです
調べてみて下さい、私も暇つぶしがてら調べてきます

ＶＢＡの基本について 重くなる・・・

こんばんは、

>限界でしょうか。

こんばんは

No.3です。

こんばんは！

プログラムの始まりに

あー、ありますよ

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

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

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

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

ＶＢＡの基本について重くなる・・・