excel vbaで教えてください。（不要行を高速に削除）

こんばんは。
下記のようなことを実行したいと思いコードを作ってみましたが処理に時間がかかります。
不要行を高速に削除できるようにしたいのでご教示ください。
・シート「１月」「２月」…「１２月」の１２枚のシートにすべて同じものが入っています。
・A列に月（数値のみ）が入っています。（約３０００行）（K列までデータあり）
・シート月（数値）とA列の数値以外の場合、行を削除する

dim j as integer
dim k as integer

for k = 1 to 12
worksheets( k & "月").select

for j = cells(Rows.count,"A").end(xlup).row to 2 step -1
if cells(j,"A") <> k then
Row(j).delete
end if
next j

next k

end sub

No.1 ベストアンサー 回答者： fujillin 回答日時： 2021/01/05 22:30

こんばんは

ひとまず、1行ずつではなくまとめて消す方式で…

※「シート月（数値）とA列の数値以外の場合」の意味がわからないので、コード中の
　＞cells(j,"A") <> k
という条件をそのまま利用しています。
※ 行を削除しますので、テスト環境でテストしてください。

Sub Sample_12122703()
Dim u, c, mon As Long

For mon = 1 To 12
　Set u = Nothing
　With Worksheets(mon & "月")
　For Each c In Range(.Cells(1, 1), .Cells(Rows.Count, 1).End(xlUp))
　　If c.Value <> mon Then
　　　If u Is Nothing Then Set u = c Else Set u = Union(u, c)
　　End If
　Next c
　If Not u Is Nothing Then u.EntireRow.Delete
　End With
Next mon

End Sub

この回答へのお礼

こんばんは。
ご提示ありがとうございます。
end if が一つ足りませんよね？
実行しましたがうまくできませんでした。

お礼日時：2021/01/06 20:23

No.8 回答者： osamuy 回答日時： 2021/01/07 09:57

・画面描画の一時停止

・ワークシート再計算の一時停止
――を行うと、そこそこスピードアップしますよ。
https://www.bing.com/search?q=Excel+VBA+%E9%AB%9 …

この回答へのお礼

ありがとうございます

お礼日時：2021/01/11 20:58

No.7 回答者： Qchan1962 回答日時： 2021/01/06 23:19

#3です

＞早速試した見たのですが、自分の入力が悪いのか１月から１２月までのデータが消えてしまいます。
＞A列の数値以外の場合
でしたね。
大変失礼しました。
＃３コードは、A列の数値と同じの場合になっていました。
If Cells(i, "A") = myAry(k) Then　を
If Cells(i, "A") <> myAry(k) Then とすると以外になると思います。

あらためて、読解力がない事で不要な時間を使わせてしまいました
すみません。

No.6 回答者： fujillin 回答日時： 2021/01/06 21:15

No1です

＞end if が一つ足りませんよね？
足りなくはありません。
（文法エラーでも出ましたか？　私の環境では出ません。）
確認のため、No1をコピペで実行してみましたが、問題なく動作します。

＞実行しましたがうまくできませんでした。
こちらの環境では、私が意図した通りの処理結果になります。
「うまくいかない」では何がどうなっているのかサッパリですが、多分、私がご説明の文章の解釈を間違えたのでしょうね。

ちなみに、何がどうなって「うまくいかない」のでしょうか？
後学のためにお知らせいただけるとありがたいです。

この回答へのお礼

私がif thenのところで改行していたため、エラーが出ていたようです。
申し訳ありませんでした。

お礼日時：2021/01/08 05:05

No.5 回答者： めぐみん_ 回答日時： 2021/01/06 09:11

＞・シート「１月」「２月」…「１２月」の１２枚のシートにすべて同じものが入っています。

この『すべて』とは何を指しているのでしょう？
まぁ流石にデータが全部同じってなら２月～１２月のシートを削除し、１月のシートから値が２～１２のデータを抽出し新規作成したシートに貼り付けるって訳にもいかないんでしょうね。

この回答へのお礼

こんばんは。
すべてとは１月～１２月のの一枚ごとのシートに同じデータの状態という意味です。（伝わりますか？）
新規シートではない方法がいいですね。

お礼日時：2021/01/06 20:20

No.3 回答者： Qchan1962 回答日時： 2021/01/05 23:14

こんばんは、

＞・シート「１月」「２月」…「１２月」の１２枚のシートにすべて同じものが入っています。
これ、信じていいのかな？良いのであれば、、かなり限定的な処理になってしまいますが、全シート纏めて削除が可能かと？
ただ、.Selectを使う事になるから早いかどうか、、

Sub Sample()
Dim i As Long, k As Long
Dim myAry As Variant
Dim myRng As Range
myAry = Array(1, 2, 3, 4, 5, 6, 7, 8, 9, 10, 11, 12)
Sheets(Array("1月", "2月", "3月", "4月", "5月", "6月", "7月", "8月", "9月", "10月", "11月", "12月")).Select
Sheets("1月").Activate
For i = 2 To Cells(Rows.Count, "A").End(xlUp).Row
For k = 0 To UBound(myAry)
If Cells(i, "A") = myAry(k) Then
If myRng Is Nothing Then
Set myRng = Cells(i, "A")
Else
Set myRng = Union(myRng, Cells(i, "A"))
End If
Exit For
End If
Next k
Next i
If Not myRng Is Nothing Then
myRng.EntireRow.Select
Selection.Delete Shift:=xlUp
End If
'おまけ
Dim sh As Worksheet
For Each sh In Worksheets
sh.Select
Range("A1").Select
Next
Sheets("1月").Activate
End Sub

Selection.Delete Shift:=xlUp　とおまけ部分をコメントアウトして
検証してください。

この回答へのお礼

こんばんは。
早速試した見たのですが、自分の入力が悪いのか１月から１２月までのデータが消えてしまいます。

お礼日時：2021/01/06 20:21

No.2 回答者： よろずやkinchan 回答日時： 2021/01/05 22:33

delete は最も遅い処理の一つです。

削除対象が下になるように並べ替えをしてから
１回で削除する方法を考えましょう。