スキルアップ・問題解決なら、モーグにおまかせ！

毎度恐縮です。
こちらのコードですが、worksheetfunctionで足し算した結果などを最終抽出というシートに転記するような式となっております。
正常に動作はするのですが、例えば大量の処理をする場合少し時間がかかってしまいます。
ここからどうやって処理を早くしようかと考えたのですが全く構想が思い浮かばず、、、、またおそらく無駄な処理もあろうかと思います。
お手数ですが、アドバイスやこういった処理が良いなどの意見をいただきたく思います。
何卒よろしくお願いいたします。
 
Option Explicit
 
Sub 月額変更()
 
Dim ws1 As Worksheet
 
Dim ws2 As Worksheet
 
Dim ws3 As Worksheet
 
Dim ws As Worksheet
 
Dim c As Long
 
Dim n As Long
 
Dim s As Long
 
Dim rng As Range
 
Dim rng2 As Range
 
Dim rng3 As Range
 
Dim rng4 As Range
 
Dim lastrow As Long
 
Dim lastcolumn As Long
 
Dim ary1 As Variant
 
Set ws1 = Sheets("月額予定一覧表")
 
Set ws2 = Sheets("最終抽出")
 
Set ws3 = Sheets("標準報酬")
 
ary1 = ws2.Range("b2").CurrentRegion
              
 For s = 2 To UBound(ary1) '最終抽出者の人数
                 
    Set rng = ws2.Range(ws2.Cells(s, 2), ws2.Cells(s, 2)) 'vlookの参照値
                     
    ws2.Cells(s, 3) = WorksheetFunction.VLookup(rng, ws1.Range("b:y"), 17, 0) '前3月
                     
    ws2.Cells(s, 5) = WorksheetFunction.VLookup(rng, ws1.Range("b:y"), 19, 0) '前2月
                     
    ws2.Cells(s, 7) = WorksheetFunction.VLookup(rng, ws1.Range("b:y"), 21, 0) '前1月
                     
    ws2.Cells(s, 4) = WorksheetFunction.VLookup(rng, ws1.Range("b:y"), 18, 0) '標準報酬月額前3月
     
    ws2.Cells(s, 6) = WorksheetFunction.VLookup(rng, ws1.Range("b:y"), 20, 0) '標準報酬月額前2月
     
    ws2.Cells(s, 8) = WorksheetFunction.VLookup(rng, ws1.Range("b:y"), 22, 0) '標準報酬月額前1月
     
 For n = 2 To ThisWorkbook.Sheets.Count
  
   Set ws = Worksheets(n)
 
    If ws.Name <> "最終抽出" Then 'シート最終抽出以外
         
      If ws.Name <> "標準報酬" Then 'シート標準報酬以外
       
        If ws.Name <> "月額予定一覧表" Then 'シート月額予定一覧表以外
             
           Debug.Print c
                  
            c = WorksheetFunction.VLookup(rng, ws.Range("b:g"), 3, 0) * -1 '前3月の合計金額
             
            ws2.Cells(s, 4) = ws2.Cells(s, 4) + c
             
            c = WorksheetFunction.VLookup(rng, ws.Range("b:g"), 4, 0) * -1 '前２月の合計金額
             
             ws2.Cells(s, 6) = ws2.Cells(s, 6) + c
              
            c = WorksheetFunction.VLookup(rng, ws.Range("b:g"), 5, 0) * -1 '前１月の合計金額
             
            ws2.Cells(s, 8) = ws2.Cells(s, 8) + c
                     
      End If
      
        End If
        
          End If
         
  Next
   
      Set rng2 = ws2.Range(ws2.Cells(s, 9), ws2.Cells(s, 9))
       
      Set rng3 = ws2.Range(ws2.Cells(s, 12), ws2.Cells(s, 12))
       
   
      ws2.Cells(s, 9) = WorksheetFunction.RoundUp((ws2.Cells(s, 4) + ws2.Cells(s, 6) + ws2.Cells(s, 8)) / 3, 0) '3月の平均金額
       
      ws2.Cells(s, 10) = WorksheetFunction.VLookup(rng, ws1.Range("b:y"), 9, 0) '従前等級健保
       
      ws2.Cells(s, 11) = WorksheetFunction.VLookup(rng, ws1.Range("b:y"), 11, 0) '従前等級厚年
       
      ws2.Cells(s, 12) = WorksheetFunction.VLookup(rng2, ws3.Range("a:e"), 2, 1) '現等級健保
       
      ws2.Cells(s, 13) = WorksheetFunction.VLookup(rng2, ws3.Range("a:e"), 4, 1) '現等級厚年
       
      ws2.Cells(s, 14) = WorksheetFunction.VLookup(rng3, ws3.Range("b:c"), 2, 1) '予定等級健保
       
      ws2.Cells(s, 15) = WorksheetFunction.VLookup(rng3, ws3.Range("d:e"), 2, 1) '予定等級厚年
 Next
 
End Sub

VLOOKUPで参照する範囲は、いつも同じですよね？
 
参照範囲を配列変数に取込みます。
一回だけ、MATCH関数で行番号を取込み、配列のINDEXとして使います。
VLOOKUP関数は使用しない方法を提案します。

追加質問

引用:

ary1 = ws2.Range("b2").CurrentRegion
    Set rng = ws2.Range(ws2.Cells(s, 2), ws2.Cells(s, 2)) 'vlookの参照値

一見した限りでは、さほど遅そうな気もしないです。(最近のエクセルは早いですからねぇ・・）
 
＞大量の処理をする場合少し時間がかかってしまいます。
当然、データ量には影響されます。
参考までに「最終抽出者の人数、シート枚数、所要時間」の現状を教えて頂けませんか？
 
ところで、これって、
　　　　　　↓
 Set rng = ws2.Range(ws2.Cells(s, 2), ws2.Cells(s, 2)) 'vlookの参照値
 Set rng = ws2.Cells(s, 2) 　　　　　　　　　　　　　　'vlookの参照値
　　　　　　↑
　　　　　これと同じことじゃないですか？

WinArrow さんの引用:
追加質問

引用:

ary1 = ws2.Range("b2").CurrentRegion
    Set rng = ws2.Range(ws2.Cells(s, 2), ws2.Cells(s, 2)) 'vlookの参照値

 
１行目のコードの目的は？
２行目のコード
Vlookup関数の検索値は、「値」ですから、ary1(s,1)で、代用できます。
わざわざ、rngオブジェクトを使う必要もないでしょう。
 

半平太 さんの引用:
一見した限りでは、さほど遅そうな気もしないです。(最近のエクセルは早いですからねぇ・・）
 
＞大量の処理をする場合少し時間がかかってしまいます。
当然、データ量には影響されます。
参考までに「最終抽出者の人数、シート枚数、所要時間」の現状を教えて頂けませんか？
 
ところで、これって、
　　　　　　↓
 Set rng = ws2.Range(ws2.Cells(s, 2), ws2.Cells(s, 2)) 'vlookの参照値
 Set rng = ws2.Cells(s, 2) 　　　　　　　　　　　　　　'vlookの参照値
　　　　　　↑
　　　　　これと同じことじゃないですか？

　なにはともあれ最初に
 
Application.Calculation = xlCalculationManual
Application.ScreenUpdating = False
 
最後に
 
Application.Calculation = xlCalculationAutomatic
Application.ScreenUpdating = True
 
ではないかと。

＞シートの枚数もだいたい４〜５枚ある時を想定します。
＞所要時間ですと現在の方法だと３８人だけで２０秒くらいかかってます。
 
その程度のデータ量で20秒とは・・・いくら何でも掛かり過ぎじゃないですかねぇ。
PCのメモリは十分積んでいますか？
 
高速化の手段として、セルにアクセスする回数を極力減らすと言う手法があります。
主に書き込み時の話ですけど。(読み出しは大したことはありません）
 
以下のコードは、逐次書込み処理は配列上で行い、セルへの書き出しは1回に抑えた場合
※PCのメモリは十分積んであることが前提です。
 

Sub 月額変更()
    Dim ws月額予定一覧表 As Worksheet
    Dim ws最終抽出 As Worksheet
    Dim ws標準報酬 As Worksheet
    Dim ws As Worksheet
    Dim c As Long
    Dim n As Long
    Dim s As Long
    Dim rng As Range
    Dim rng2 As Range
    Dim rng3 As Range
    Dim rng4 As Range
    Dim lastrow As Long
    Dim lastcolumn As Long
    Dim ary1 As Variant
    
    Set ws月額予定一覧表 = Sheets("月額予定一覧表")
    Set ws最終抽出 = Sheets("最終抽出")
    Set ws標準報酬 = Sheets("標準報酬")
    
    'C列から値を 配列Ary1 に格納する
    ary1 = Intersect(ws最終抽出.Range("b2").CurrentRegion, ws最終抽出.Columns("C:O")).Value
    
    For s = 2 To UBound(ary1) '最終抽出者の人数
        Set rng = ws最終抽出.Cells(s, 2)                   'vlookの参照値
        
        Dim posInWs月額予定一覧表ColB
        posInWs月額予定一覧表ColB = WorksheetFunction.Match(rng, ws月額予定一覧表.Columns("B"), 0)
        
        ary1(s, 1) = ws月額予定一覧表.Cells(posInWs月額予定一覧表ColB, 18) '前3月
        ary1(s, 3) = ws月額予定一覧表.Cells(posInWs月額予定一覧表ColB, 20) '前2月
        ary1(s, 5) = ws月額予定一覧表.Cells(posInWs月額予定一覧表ColB, 22) '前1月
        ary1(s, 2) = ws月額予定一覧表.Cells(posInWs月額予定一覧表ColB, 19) '標準報酬月額前3月
        ary1(s, 4) = ws月額予定一覧表.Cells(posInWs月額予定一覧表ColB, 21) '標準報酬月額前2月
        ary1(s, 6) = ws月額予定一覧表.Cells(posInWs月額予定一覧表ColB, 23) '標準報酬月額前1月
        
        For n = 2 To ThisWorkbook.Sheets.Count
            Set ws = Worksheets(n)
            
            If ws.Name <> "最終抽出" Then 'シート最終抽出以外
                If ws.Name <> "標準報酬" Then 'シート標準報酬以外
                    If ws.Name <> "月額予定一覧表" Then 'シート月額予定一覧表以外
                        Dim posInWsColB
                        posInWsColB = WorksheetFunction.Match(rng, ws.Columns("B"), 0)

                        c = ws.Cells(posInWsColB, "D") * -1 '前3月の合計金額
                        ary1(s, 2) = ary1(s, 2) + c
                        c = ws.Cells(posInWsColB, "E") * -1  '前２月の合計金額
                        ary1(s, 4) = ary1(s, 4) + c
                        c = ws.Cells(posInWsColB, "F") * -1 '前１月の合計金額
                        ary1(s, 6) = ary1(s, 6) + c
                    End If
                End If
            End If
        Next
        
        Set rng2 = ws最終抽出.Cells(s, 9)
        Set rng3 = ws最終抽出.Cells(s, 12)
        
        ary1(s, 7) = WorksheetFunction.RoundUp((ary1(s, 2) + ary1(s, 4) + ary1(s, 6)) / 3, 0) '3月の平均金額
        
        ary1(s, 8) = WorksheetFunction.VLookup(rng, ws月額予定一覧表.Range("b:y"), 9, 0) '従前等級健保
        ary1(s, 9) = WorksheetFunction.VLookup(rng, ws月額予定一覧表.Range("b:y"), 11, 0) '従前等級厚年
        ary1(s, 10) = WorksheetFunction.VLookup(rng2, ws標準報酬.Range("a:e"), 2, 1) '現等級健保
        ary1(s, 11) = WorksheetFunction.VLookup(rng2, ws標準報酬.Range("a:e"), 4, 1) '現等級厚年
        ary1(s, 12) = WorksheetFunction.VLookup(rng3, ws標準報酬.Range("b:c"), 2, 1) '予定等級健保
        ary1(s, 13) = WorksheetFunction.VLookup(rng3, ws標準報酬.Range("d:e"), 2, 1) '予定等級厚年
    Next
    
    '書き出し
    ws最終抽出.Range("C1").Resize(UBound(ary1), UBound(ary1, 2)) = ary1
End Sub

higejee さんの引用:
　なにはともあれ最初に
 
Application.Calculation = xlCalculationManual
Application.ScreenUpdating = False
 
最後に
 
Application.Calculation = xlCalculationAutomatic
Application.ScreenUpdating = True
 
ではないかと。

   
    '書き出し
    ws最終抽出.Range("C1").Resize(UBound(ary1), UBound(ary1, 2)) = ary1
End Sub[/code][/quote]
 
いつもお世話になっております。
 
コードのご提示ありがとうございます。
時間については少しどんぶり勘定でした。もう少し早いかもしれません。
まだ動かしてはいないのですが、一件ご教示ください。
こちらのコードは書き出しとあるのですが、どのようなことをしているのでしょうか。

　勝手に代返しますが、二次元配列 ary1 の全要素を、同じサイズのセル領域に（一括して）書き出す、ということです。個々のセルにひとつずつ書き出すより確実に早いです。

処理の前に、

    Dim t
    t = Timer

    Debug.Print Timer - t

       
      ary1(s, 10) = WorksheetFunction.VLookup(ary1(s, 7), ws3.Range("a:e"), 2, 1) '現等級健保
       
      ary1(s, 11) = WorksheetFunction.VLookup(ary1(s, 7), ws3.Range("a:e"), 4, 1) '現等級厚年
       
      ary1(s, 12) = WorksheetFunction.VLookup(ary1(s, 10), ws3.Range("b:c"), 2, 1) '予定等級健保
      ary1(s, 13) = WorksheetFunction.VLookup(ary1(s, 11), ws3.Range("d:e"), 2, 1) '予定等級厚年
 
ありがとうございました。
こちらのコードがエラーになってしまったので、上記のように直した結果正常に動きます。

higejee さんの引用:
　勝手に代返しますが、二次元配列 ary1 の全要素を、同じサイズのセル領域に（一括して）書き出す、ということです。個々のセルにひとつずつ書き出すより確実に早いです。

simple さんの引用:
処理の前に、

    Dim t
    t = Timer

を挿入し、
処理後に

    Debug.Print Timer - t

とすることで、実行時間(秒）をイミディエイトウインドウに出せます。
 
現状、及び皆さんの回答について、それぞれ所要時間を示されるとよいでしょう。