VBA代码优化

Question

我有下面的代码，但非常慢。有没有办法改善它？我是VBA的初学者，非常感谢您的帮助。它所做的是遍历一个表，并在每个工作表中查找匹配的条件，并相应地给出值。在初始范围内，条件各行不同：

Sub TAB_REF_SETUP()
    Dim TC As Integer
    Dim TR As Integer
    Dim C As Integer
    Dim C2 As Integer
    Dim R As Integer
    Dim R2 As Integer
    Dim TC2 As Integer
    Dim TR2 As Integer
    Dim CELL2 As Range
    Dim CELL As Range
    Dim RNG2 As Range
    Dim RNG As Range
    Dim WKS As Worksheet
    Dim a As String
    Dim xrow As Integer
    Dim ycol As Integer
    Dim CEllrow As Integer
    Dim cellcol As Integer
    Dim mincol As Integer
    Dim mfrcol As Integer
    Dim schrefc As Integer
    Dim RBC As Integer
    Dim RTC As Integer
    Dim b As String
    Dim CPC As Integer
    Dim D As String
    Dim AR As String
    Dim StartTime As Double
    Dim SecondsElapsed As Double
    StartTime = Timer
    'Application.ScreenUpdating = False
    Application.AutoCorrect.AutoFillFormulasInLists = False
    Application.CellDragAndDrop = False
    Application.Calculation = xlCalculationManual
    If ActiveSheet.AutoFilterMode = True Then
        ActiveSheet.ShowAllData
    Else
    End If

    C = Range("1:1").Find("Dist Classification").Column
    If Range("1:1").Find("Schedule A Ref") Is Nothing Then
        Columns(C + 1).Insert
        Columns(C + 2).Insert
        Columns(C + 3).Insert
        Cells(1, C + 1).Value = "Schedule A Ref"
        Cells(1, C + 2).Value = "Contract Name"
        Cells(1, C + 3).Value = "Lookup Value"
        schrefc = Range("1:1").Find("Schedule A Ref").Column
        GoTo CellFill
    Else
        schrefc = Range("1:1").Find("Schedule A Ref").Column
        If MsgBox("Ref Tab Exists. Do you want to proceed with further check?", vbYesNo, "Perform Further Check") = vbYes Then
            If MsgBox("This will re-write column ""Schedule A Ref"". Do you wish to continue ?", vbYesNo, "Are you sure?") = vbYes Then
CellFill:
                TC = Range("A1").End(xlToRight).Column
                TR = Range("A1").End(xlDown).Row
                Cells(1, TC + 1) = "Applicable Rebate"
                Cells(1, TC + 2) = "Applicable Rebate Type"
                Cells(1, TC + 3) = "Applicable Contract Price"
                Cells(1, TC + 4) = "Actual Rebate $ for Line"
                Cells(1, TC + 5) = "Rebate Owed"
                Set RNG = Range(Cells(2, schrefc), Cells(Range("a1").End(xlDown).Row, schrefc))
                mincol = Range("1:1").Find("MIN").Column
                mfrcol = ActiveSheet.Range("1:1").Find("Mfr Name").Column
                For Each CELL In RNG
                    CEllrow = CELL.Row
                    For Each WKS In Worksheets
                        If Not WKS.Range("1:1").Find("Schedule") Is Nothing And Not WKS.Range("1:3").Find(Cells(CEllrow, mfrcol)) Is Nothing And (InStr(1, WKS.Name, "fort", vbTextCompare) = 0 And InStr(1, WKS.Name, "report", vbTextCompare) = 0 And InStr(1, WKS.Name, "data", vbTextCompare) = 0) Then
                            C2 = WKS.Range("1:5").Find("Contract Name").Column
                            R2 = WKS.Range("1:5").Find("Contract Name").Row
                            TR2 = WKS.Range("1:5").Find("Contract Name").End(xlDown).Row
                            TC2 = C2
                            Set RNG2 = WKS.Range(WKS.Cells(R2 + 1, C2), WKS.Cells(TR2, C2))
                            xrow = WKS.Range("1:5").Find("SCC&Tab").Row
                            ycol = WKS.Range("1:5").Find("SCC&Tab").Column
                            RBC = WKS.Range("1:5").Find("Applicable Rebate").Column
                            RTC = WKS.Range("1:5").Find("Applicable Rebate Type").Column
                            CPC = WKS.Range("1:5").Find("Applicable Contract Price").Column

                            a = "=iferror(vlookup([@[Lookup Value]],indirect([@[Schedule A Ref]])," & RBC & ",false),iferror(vlookup([@[Dist Mfr. Item ID]]&[@[Contract Name]],indirect([@[Schedule A Ref]])," & RBC & ",false),""""))"
                            b = "=iferror(vlookup([@[Lookup Value]],indirect([@[Schedule A Ref]])," & RTC & ",false),iferror(vlookup([@[Dist Mfr. Item ID]]&[@[Contract Name]],indirect([@[Schedule A Ref]])," & RTC & ",false),""""))"
                            D = "=iferror(vlookup([@[Lookup Value]],indirect([@[Schedule A Ref]])," & CPC & ",false),iferror(vlookup([@[Dist Mfr. Item ID]]&[@[Contract Name]],indirect([@[Schedule A Ref]])," & CPC & ",false),""""))"
                            For Each CELL2 In RNG2
                                If InStr(1, CELL2, Cells(CEllrow, C), vbTextCompare) > 0 Then
Filler:
                                    CELL.Value = "''" & WKS.Name & "'!" & WKS.Cells(xrow, ycol).Address & ":" & Cells(RNG2.End(xlDown).Row, RNG2.End(xlUp).End(xlToRight).Column).Address
                                    Cells(CEllrow, C + 2).Value = CELL2
                                    Cells(CEllrow, C + 3).Value = "=[@[Min]]&[@[Contract Name]]"
                                    Cells(CEllrow, TC + 1) = a
                                    Cells(CEllrow, TC + 2) = b
                                    Cells(CEllrow, TC + 3) = D
                                    If Cells(CEllrow, TC + 2).Value = "%D" Then
                                        AR = "=[@[Applicable Rebate]]*[@[Applicable Contract Price]]*[@[case qty]]"
                                    ElseIf Cells(CEllrow, TC + 2).Value = "$" Then
                                        AR = "=[@[Applicable Rebate]]*[@[case qty]]"
                                    ElseIf Cells(CEllrow, TC + 2).Value = "%P" Then
                                        AR = "=[@[Applicable Rebate]]*[@[Total Vol]]"
                                    Else
                                        AR = "0"
                                    End If
                                    Cells(CEllrow, TC + 4) = AR
                                    Cells(CEllrow, TC + 5) = "=[@[Actual Rebate $ for Line]]-[@[Committed - Rebate]]"
                                ElseIf InStr(1, CELL2, "nat", vbTextCompare) > 0 Then
                                    GoTo Filler:
                                Else
                                End If
                            Next
                        Else
                        End If
                    Next
                Next
            Else
                Exit Sub
            End If
        Else
            Exit Sub
        End If
    End If
    Application.AutoCorrect.AutoFillFormulasInLists = True
    Application.Calculation = xlCalculationAutomatic
    Application.CellDragAndDrop = True
    Application.ScreenUpdating = True
    SecondsElapsed = Round(Timer - StartTime, 2)

    'Notify user in seconds
     MsgBox "This code ran successfully in " & SecondsElapsed & " seconds", vbInformation
End Sub

Answer 1

必须做的事情：

从顶部取消注释：Application.ScreenUpdating = False：

：一个好主意：

将所有integer更改为以不使用goto statements的方式进行切换。安装此-> http://www.oaltd.co.uk/indenter/indentpage.asp并缩进。或者如注释中所述，使用RubberDuck缩进器。

Answer 2

最慢的部分似乎是在细胞中循环。改用下面的代码：

Dim vData as Variant
Dim arrayIndex1 as Long, arrayIndex2 as Long

vData = Range(Cells(2, schrefc), Cells(Range("a1").End(xlDown).Row, schrefc))

For arrayIndex1 = lbound(vData) to ubound(vData)
    For arrayIndex2 = lbound(vData,2) to ubound(vData,2)
        'vData(arrayIndex1,arrayIndex2)       
    Next arrayIndex2
Next arrayIndex1

vData(arrayIndex1,arrayIndex2)是cells(row,col)的数组副本。默认情况下，数组从0开始，因此第一个arrayIndex1将等于0。要将默认值更改为1，请使用代码顶部的Option Base 1。

对于多个相同的对象使用With语句，以提高代码清晰度-当在循环中时，也会提高性能，例如，而不是：

 xrow = WKS.Range("1:5").Find("SCC&Tab").Row
 ycol = WKS.Range("1:5").Find("SCC&Tab").Column
 RBC = WKS.Range("1:5").Find("Applicable Rebate").Column
 RTC = WKS.Range("1:5").Find("Applicable Rebate Type").Column
 CPC = WKS.Range("1:5").Find("Applicable Contract Price").Column

使用：

With WKS.Range("1:5")
   xrow = .Find("SCC&Tab").Row
   ycol = .Find("SCC&Tab").Column
   RBC = .Find("Applicable Rebate").Column
   RTC = .Find("Applicable Rebate Type").Column
   CPC = .Find("Applicable Contract Price").Column
End With

还可以尝试声明像Dim TC As Long, TR As Long, C as Long这样的变量，这样声明就不会占代码行数的一半。操作系统无论如何都会将integer转换为long，所以不要使用整数。例如，使用Cells(CEllrow, C).value代替单元格(CEllrow，C)。