VBAコードの高速化

Question

基本的に2つのワークブックの参照番号と一致し、関連する情報を新しいワークシートに書き込んでいるときに、問題が発生しました。まず、サイズについていくつかの詳細を教えてください。ブックの1つには1987行と66列があり、もう1つには15645行と13列があります。コードの後の新しいワークシートには、5643行と41列があります。私の場合は平均コードが2分10秒で長すぎます。私はコードを高速化するためにいくつかのことを試みましたが、うまくいかなかったのです。どのような助けでもありがとう！

Sub take_swap_values() 

    With Application 
       .ScreenUpdating = False 
       .DisplayStatusBar = False 
       .Calculation = xlCalculationManual 
       .EnableEvents = False 
    End With 


    Dim h, f As Long 
    Dim r As Integer 

    h = Application.WorksheetFunction.Count(Workbooks("swap.xlsx").Sheets("Sheet3").Range("$B$2:$B$1987")) 
    f = Application.WorksheetFunction.Count(Workbooks("swp_fwd.xlsm").Sheets("Sheet1").Range("$A$2:$A$5645")) 

    Workbooks("swap.xlsx").Activate 
    Workbooks("swp_fwd.xlsm").Activate 
    Workbooks("swp_fwd.xlsm").Sheets("Sheet2").Cells(1, 1).Value = Workbooks("swp_fwd.xlsm").Sheets("Sheet1").Cells(1, 1).Value 

    For i = 1 To h 
     For j = 1 To f 
      If Workbooks("swap.xlsx").Sheets("Sheet3").Cells(i, 2).Value = Workbooks("swp_fwd.xlsm").Sheets("Sheet1").Cells(j, 1).Value Then 
       For k = 1 To 40 
        Workbooks("swp_fwd.xlsm").Sheets("Sheet2").Cells(j, k).Value = Workbooks("swap.xlsx").Sheets("Sheet3").Cells(i, k) 
       Next k 
      End If 
     Next j 
    Next i 

    With Application 
     .ScreenUpdating = True 
     .DisplayStatusBar = True 
     .Calculation = xlCalculationAutomatic 
     .EnableEvents = True 
    End With 

End Sub 

Answer 1

大量のデータを繰り返し処理する必要があるコードの処理速度を上げるため、配列の操作には恵まれました。 以下のコードを試してください...私は、さまざまな部分を説明するためにコメントしました。ご質問がある場合はお知らせください。

Option Explicit 'always use this ... it will help eliminate simple errors in coding and variables 

    Sub take_swap_values() 
    'declare your variables 
    Dim swpWB As Workbook 
    Dim swpWS As Worksheet 
    Dim swpRng As Range 
    Dim swpArr 'array variable 

    Dim swp_fwdWB As Workbook 
    Dim swp_fwdWS1 As Worksheet 
    Dim swp_fwdWS2 As Worksheet 
    Dim swp_fwdRng As Range 
    Dim swp_fwdArr 'array variable 

    Dim i As Long, j As Long 

    With Application 
       .ScreenUpdating = False 
       .DisplayStatusBar = False 
       .Calculation = xlCalculationManual 
       .EnableEvents = False 'probably don't need this unless there are worksheet change macros running 
    End With 

    'instantiate your variables 
    Set swpWB = Application.Workbooks("swap.xlsx") 
    Set swpWS = swpWB.Sheets("Sheet3") 
    Set swpRng = swpWS.Range("$B$2:$B$1987") 

    Set swp_fwdWB = Application.Workbooks("swp_fwd.xlsm") 
    Set swp_fwdWS1 = swp_fwdWB.Sheets("Sheet1") 
    Set swp_fwdRng = swp_fwdWS1.Range("$A$2:$A$5645") 

    Set swp_fwdWS2 = swp_fwdWB.Sheets("Sheet2") 

    swp_fwdWS2.Cells(1, 1).Value = swp_fwdWS1.Cells(1, 1).Value 

    'fill arrays with values from the ranges 
    swpArr = swpRng.Value 
    swp_fwdArr = swp_fwdRng.Value 

    'loop through each array ... these are one dimensional arrays meaning they have only a multiplicity of rows and not rows and columns 
    For i = LBound(swpArr) To UBound(swpArr) 'Lbound stands for Lower Bound and Ubound stands for Upper Bound 
     For j = LBound(swp_fwdArr) To UBound(swp_fwdArr) 
      If swpArr(i, 1) = swp_fwdArr(j, 1) Then 
       'set value of entire range from column 1 to column 40 on that row to the same range of columns for swpWS 
       With swp_fwdWS2 
        .Range(.Cells(j + 1, 1), .Cells(j + 1, 40)).Value = swpWS.Range(swpWS.Cells(i + 1, 1), swpWS.Cells(i + 1, 40)).Value 'a 1 gets added because the array does not include the header column 
       End With 
      End If 
     Next j 
    Next i 

    With Application 
     .ScreenUpdating = True 
     .DisplayStatusBar = True 
     .Calculation = xlCalculationAutomatic 
     .EnableEvents = True 
    End With 

End Sub 

編集：私はダミーデータでテストやコードが範囲をループに5秒かかりました...燃えるされた多くのデータをループするために、それは二回しか試合を見つけましたが、5秒付与されました！