VBA Code optimizing [closed] - vba

Question

Closed. This question needs to be more focused. It is not currently accepting answers.
Want to improve this question? Update the question so it focuses on one problem only by editing this post.
Closed 6 years ago.
Improve this question
I have the below code, but is very slow. Is there a way to improve it? I'm a beginner with VBA and would appreciate your help. What it does is it goes through a table and looks up in each worksheet for criteria to match and give values accordingly. Criteria differ by line in the initial range:
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

Must do:
Uncomment from the top this:
Application.ScreenUpdating = False
A good idea to do:
Change all integer to long
Rewrite it in a way that you do not use goto statements. Install this -> http://www.oaltd.co.uk/indenter/indentpage.asp and indent. Or as mentioned in the comments, use the RubberDuck indenter.

Answer 2

The slowest part seems to be looping through cells. Use this instead:
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) is array counterpart of cells(row,col). By default arrays start from 0, so first arrayIndex1 will equal 0. To change default value to 1, use Option Base 1 at the top of the code.
Use With statement for multiple identical objects for better code clarity - and when inside a loop, also performance, for example instead of:
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
use:
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
Also try declaring variables like Dim TC As Long, TR As Long, C as Long so that declarations are not half of code's lines. Operating system converts integer to long anyway, so don't use integers. Use for example Cells(CEllrow, C).value instead of Cells(CEllrow, C).