Excel VBAについて

質問

Excel　VBAについて教えて頂きたいのですが、
Sub test()
Dim lastrow, r, i As Long
Dim sh1, sh2 As String
Dim ws As Worksheet
lastrow = Cells(Rows.count, "D").End(xlUp).row
For r = 7 To lastrow '7
For i = 1 To lastrow '4
sh1 = ActiveSheet.Cells(r, 4)
ActiveSheet.Cells(r, 20) = _
Application.CountIfs(Sheets(sh1).Range("D:D"), Range("H3") & Range("I3"), Sheets(sh1).Range("K:K"), "<=3") _
/ Application.CountIf(Sheets(sh1).Range("D:D"), Range("H3") & Range("I3"))

ActiveSheet.Cells(r, 21) = _
Application.CountIfs(Sheets(sh1).Range("C:C"), Range("F3"), Sheets(sh1).Range("K:K"), "<=3") _
/ Application.CountIf(Sheets(sh1).Range("C:C"), Range("F3"))

ActiveSheet.Cells(r, 22) = _
Application.CountIfs(Sheets(sh1).Range("E:E"), Range("K3"), Sheets(sh1).Range("K:K"), "<=3") _
/ Application.CountIf(Sheets(sh1).Range("E:E"), Range("K3"))

Sheets(sh1).Range("A3:R3").AutoFilter Field:=4, Criteria1:=Range("H3") & Range("I3")
ActiveSheet.Cells(r, 15) = Application.Subtotal(105, Sheets(sh1).Range("O:O"))

Sheets(sh1).Range("A3:R3").AutoFilter Field:=4, Criteria1:=Range("H3") & Range("I3") - 200
ActiveSheet.Cells(r, 18) = Application.Subtotal(105, Sheets(sh1).Range("O:O"))

Sheets(sh1).Range("A3:R3").AutoFilter Field:=4, Criteria1:=Range("H3") & Range("I3") + 200
ActiveSheet.Cells(r, 19) = Application.Subtotal(105, Sheets(sh1).Range("O:O"))
For Each ws In Worksheets
ws.AutoFilterMode = False
Next
Next
Next
End Sub

このコードは
ActiveSheetで実行すると
D列の7行目から最終行までに入力されている名前のシート（名前＝シートがあります）
その、シートの参照先で
C,D,E列がcountif関数を利用して
O列がSubtotal関数を利用しています。

このコードでもやりやいことは実行できるのですが、
時間がかかりすぎてしまいます。
約20件あり約２分ほどかかります。パソコンによっては倍ほど時間がかかるかもです。

そこでなのですが、
もっと処理のスピードを上げたいのですが、
可能でしょうか？
可能ならそのやり方をご教示ください。

よろしくお願い致します。

回答No.2

kagakusuki · ベストアンサー

確認したい点があります。

sh1 = ActiveSheet.Cells(r, 4)

から

ActiveSheet.Cells(r, 19) = Application.Subtotal(105, Sheets(sh1).Range("O:O"))

までの所で行っている処理には変数 i が全く登場しておらず、一見すると
For i = 1 To lastrow '4
の繰り返し処理において、同じ値をセルに入力するという1回行えば済む処理をlastrow の行数と同じ回数だけ繰り返し行うという無駄な繰り返しを行っている様に見えるのですが、これはもしかしますと各シートにワークシート関数が入力されているセルがあり、関数の出力結果によって、セルに入力する値が変わって来るという事なのでしょうか？
　もしそうではなく、各シートには特にワークシート関数が使われているセルは存在していないという場合には、

>時間がかかりすぎてしまいます。

という事が起きる原因は

For i = 1 To lastrow '4

の繰り返し処理にありますので、その繰り返し処理は行わない様にした方が良いと思います。
　それからオートフィルターは処理速度が遅いため、むしろFor等の繰り返し処理で1行ずつデータを確認して行った方が処理に要する時間が短くなる場合が少なくありません。

Sub test_改()
Dim lastrow As Long, lastrow2 As Long, r As Long, j As Long _
, buf As Variant, myMin(2) As Double

lastrow = Cells(Rows.Count, "D").End(xlUp).Row

With Application
.ScreenUpdating = False
.Calculation = xlManual
End With

For r = 7 To lastrow '7
With Sheets(ActiveSheet.Cells(r, 4))
ActiveSheet.Cells(r, 20) = _
WorksheetFunction.CountIfs(.Range("D:D"), Range("H3") & Range("I3"), .Range("K:K"), "<=3") _
/ WorksheetFunction.CountIf(.Range("D:D"), Range("H3") & Range("I3"))

ActiveSheet.Cells(r, 21) = _
WorksheetFunction.CountIfs(.Range("C:C"), Range("F3"), .Range("K:K"), "<=3") _
/ WorksheetFunction.CountIf(.Range("C:C"), Range("F3"))

ActiveSheet.Cells(r, 22) = _
WorksheetFunction.CountIfs(.Range("E:E"), Range("K3"), .Range("K:K"), "<=3") _
/ WorksheetFunction.CountIf(.Range("E:E"), Range("K3"))

lastrow2 = .Cells(.Rows.Count, "O").End(xlUp).Row
myMin(0) = WorksheetFunction.Max(.Columns("O"))
For j = 0 To UBound(myMin)
myMin(j) = myMin(0)
Next j
If lastrow2 > 3 Then
For j = 4 To lastrow2
buf = .Range("O" & j).Value
If .Range("D" & j).Value = Range("H3") & Range("I3") _
And buf <> "" And buf < myMin(0) Then myMin(0) = buf
If .Range("D" & j).Value = Range("H3") & Range("I3") - 200 _
And buf <> "" And buf < myMin(1) Then myMin(1) = buf
If .Range("D" & j).Value = Range("H3") & Range("I3") + 200 _
And buf <> "" And buf < myMin(2) Then myMin(2) = buf
Next j
End If
ActiveSheet.Cells(r, 15) = myMin(0)
ActiveSheet.Cells(r, 18) = myMin(1)
ActiveSheet.Cells(r, 19) = myMin(2)
End With
Next r

With Application
.Calculation = xlAutomatic
.ScreenUpdating = True
End With

End Sub

お礼

コメントありがとうございます。

なぜかwith　～　End with が使えなかったため
その辺は、変数sh1 にて質問どおりで
他はコードを試させて頂きました。

ものすごく速くてびっくりしました。

回答者No1様のも倍くらい早かったのですが
No2様に掲示して頂いたコードでは数秒で処理が終わりました！

補足

変数i　は消すのを忘れていました・・・

回答No.1

neKo_quatre

> もっと処理のスピードを上げたいのですが、

定番の方法だと、処理の前に、
・画面の更新を停止する
・自動計算を停止する
って方法があります。

Sub test()

' 処理前に、
Application.ScreenUpdating = False
Application.Calculation = xlCalculationManual

' ここで実際の処理
' ～

' 処理の後で、
Application.ScreenUpdating = True
Application.Calculation = xlCalculationAutomatic

End Sub

お礼

コメントありがとうございます。

このコードは、call で呼び出ししていて
その先に
Application.ScreenUpdating = False
Application.Calculation = xlCalculationManual

はいれていたのです。
しかし、直接コードに入れると倍くらい速くなりました。
ありがとうございます。