Ускорение кода VBA

Question

У меня возникли проблемы с моим кодом, который в основном соответствует номерам ссылок из двух книг и записывает соответствующую информацию на новый рабочий лист. Прежде всего, позвольте мне подробно рассказать о размерах. Одна из книг имеет 1987 строк и 66 столбцов, а другая - 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 

EDIT: Я тестировал на фиктивные данные и код потребовалось 5 секунд, чтобы перебрать диапазон ... получил он только нашел матч в два раза, но через 5 секунд Переберите, что много данных пылает!