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

编辑：我测试了虚拟数据并且代码花了5秒钟来循环遍历范围...授予它只找到一个匹配两次，但是循环通过那么多数据的5秒就是炽热！

加速VBA代码

1 个答案: