加快VBA代码

我对我的代码感到困扰，它基本上与两个工作簿的参考号码相匹配，并将相关信息写入新的工作表。 首先，让我给一些关于尺寸的细节。 其中一本工作簿有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

我已经有了与arrays的好运，以加快您需要迭代大量数据的代码。 尝试下面的代码…我已经评论它来帮助解释不同的部分。 如果您有任何问题，请告诉我。

  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 

编辑：我testing了虚拟数据和代码花了5秒循环通过范围…授予它只发现了一场比赛两次，但5秒循环通过这么多的数据是炽烈的！