我有以下代码，但速度很慢。有没有办法改善它？我是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
答案 0 :(得分：1)
必须：
Application.ScreenUpdating = False 这是一个好主意：
integer更改为long statements的方式重写它。安装此 - ＆gt; http://www.oaltd.co.uk/indenter/indentpage.asp并缩进。或者如评论中所述，使用RubberDuck压头。 答案 1 :(得分：0)
最慢的部分似乎是循环细胞。请改用：
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）。