Can someone please help me speed up my macro?

Hi,

I was hoping someone could help with any obvious ways to speed up the below macro?

Essentially, it is an overarching For-Next loop with multiple arrays, looping through arrays and a couple of dictionaries.

I often need to run it for over 100 cycles with 3,000 - 4,000 rows of data. Unfortunately this can take hours, even days to complete.

Any help would be greatly appreciated.

Sub RefineArray()

Dim FactorString As String
Dim FactorVal As Variant
Dim CashFactorVal As Variant
Dim IndustryString As String
Dim FactorCol As String
Dim ValuationCol As String
Dim ValuationColNum As Integer
Dim ValuationColLet As String
Dim ValuationRow As Integer
Dim FactorColNum As Integer
Dim FactorColLet As String
Dim LastValueColNum As Integer
Dim LastDataCol As String
Dim LastValueCol As String
Dim FinalValueRow As Integer
Dim FirstCompFactor As String
Dim SecondCompFactor As String
Dim PrevFirstCompFactor As String
Dim FirstCompFactorSign As String
Dim PrevCompFactorSign As String
Dim RefinedReturn As Variant
Dim wb As Workbook: Set wb = Application.ThisWorkbook
Dim wbR As Workbook: Set wbR = Workbooks("Refiner.xlsb")

Dim RefLastColNum As Integer
Dim RefLastCol As String
Dim RefFinalRow As Integer

'Define Refiner Last Column and LastRow
RefLastColNum = wbR.Sheets("Data").Cells(2, Columns.Count).End(xlToLeft).Column
RefLastCol = Split(Cells(1, RefLastColNum).Address, "$")(1)
RefFinalRow = wbR.Worksheets("Data").Range("CE" & Rows.Count).End(xlUp).Row

'-----Array Variables
Dim ValuationArray() As Variant
Dim ValuationTableArray() As Variant
Dim FactorDataArray() As Variant
Dim FactorValueArray() As Variant
Dim FactorValueSumArray() As Variant

Dim ArrayCount As Long

'Valuation Array Variables
Dim Val As Variant
Dim ValForm As Variant
Dim ValString As String
Dim CompVal As Variant
Dim ValDiff As Variant
Dim ValMin As Variant
Dim RemRet As Variant

Dim RefPercent As Variant

Dim FactorMatchColNum As Integer
Dim FactorMatchCol As String
Dim FactorName As String
Dim MultiplierVal As Variant
Dim FormulaVal As Variant
Dim Valuation As Variant
Dim TotAgg As Variant
Dim TotRefRet As Variant
Dim FactorSum As Variant
Dim FactorWSum As Variant
Dim FactorAWSum As Variant
Dim FactorComp As String
Dim FactorABSVal As Variant

Dim ValuationFormulas As Object
Set ValuationFormulas = CreateObject("Scripting.Dictionary")
Dim ValuationTable As Object
Set ValuationTable = CreateObject("Scripting.Dictionary")
Dim ValTable As Object
Set ValTable = CreateObject("Scripting.Dictionary")

'----------------------------------------------------------------
Application.Calculation = xlManual

IndustryString = wb.Sheets("Data").Range("C4").Value

FinalValueRow = wb.Sheets("Valuation Table").Range("A" & Rows.Count).End(xlUp).Row

'----------------------------------------------------------------

'<<<<Define Valuation Table Array>>>>>
ArrayCount = 0

For FactorMatchColNum = 21 To 79
FactorMatchCol = Split(Cells(1, FactorMatchColNum).Address, "$")(1)

'Define Factor Columns
ValColNum = WorksheetFunction.Match(Sheets("Data").Range(FactorMatchCol & "2").Value, wb.Sheets("Valuation Table").Range("A1:BI1"), 0)
ValCol = Split(Cells(1, ValColNum).Address, "$")(1)

'Populate Array
For Count = 3 To FinalValueRow
ReDim Preserve ValuationTableArray(2, ArrayCount)

If wb.Sheets("Valuation Table").Range(ValCol & Count).Value <> "" Then
ValuationTableArray(0, ArrayCount) = wb.Sheets("Valuation Table").Range(ValCol & "1").Value
ValuationTableArray(1, ArrayCount) = wb.Sheets("Valuation Table").Range(ValCol & Count).Value
ValuationTableArray(2, ArrayCount) = wb.Sheets("Valuation Table").Range("B" & Count).Value

ArrayCount = ArrayCount + 1
End If

Next

Next

'--------------------------------------------------------------------

'<<<Define Factor Data Array>>>

ArrayCount = 0

For FactorMatchColNum = 21 To 79
If FactorMatchColNum <> 27 Then

FactorMatchCol = Split(Cells(1, FactorMatchColNum).Address, "$")(1)

'Define Factor Columns
FactorColNum = WorksheetFunction.Match(Sheets("Data").Range(FactorMatchCol & "2").Value, wb.Sheets("Data").Range("CB2:" & RefLastCol & "2"), 0) + 79
FactorValCol = Split(Cells(1, FactorColNum).Address, "$")(1)
FactorName = wb.Sheets("Data").Range(FactorValCol & "2").Value

For Count = 4 To RefFinalRow Step 1

FactorVal = wb.Sheets("Data").Range(FactorValCol & Count).Value

'Populate Array
If Evaluate("Mod(" & Count & ",3)") <> 0 Then
ReDim Preserve FactorDataArray(2, ArrayCount)
FactorDataArray(0, ArrayCount) = FactorName
FactorDataArray(1, ArrayCount) = FactorVal
FactorDataArray(2, ArrayCount) = Count

ArrayCount = ArrayCount + 1
End If
Next
End If
Next

Application.StatusBar = "Loading..."
DoEvents

'----------------------------------------------------------------------------
'Start Loop cycle

For InnerCount = 1 To 5

'Create Valuation formula Dictionary
For ThisCount = 4 To RefFinalRow
If Evaluate("Mod(" & ThisCount & ",3)") <> 0 Then
ValFormCount = 1

'Search first formula Factor and define the Factor name and Factor Column
For FactorMatchColNum = 21 To 79
FactorMatchCol = Split(Cells(1, FactorMatchColNum).Address, "$")(1)
FactorName = wb.Sheets("Data").Range(FactorMatchCol & "2").Value

'Define Industry
IndustryString = wb.Sheets("Data").Range("C" & ThisCount).Value

'Locate Multiplier Value in Valuation Table Array
For i = LBound(ValuationTableArray, 2) To UBound(ValuationTableArray, 2)
If ValuationTableArray(0, i) = FactorName And ValuationTableArray(2, i) = IndustryString Then
MultiplierVal = ValuationTableArray(1, i)
End If

Next

If MultiplierVal = 0 Then
FormulaVal = 1
Else

'Locate Factor Value in Factor Data Array
For i = LBound(FactorDataArray, 2) To UBound(FactorDataArray, 2)
If FactorDataArray(0, i) = FactorName And FactorDataArray(2, i) = ThisCount Then
FactorVal = FactorDataArray(1, i)
FormulaVal = Application.WorksheetFunction.Power(FactorVal, MultiplierVal)
Exit For
End If
Next
End If
ValuationFormulas(ValFormCount) = FormulaVal
'MsgBox ValuationFormulas(ValFormCount)
ValFormCount = ValFormCount + 1

Next

Valuation1 = ValuationFormulas(1) * ValuationFormulas(2) * ValuationFormulas(3) * ValuationFormulas(4) * ValuationFormulas(5) * ValuationFormulas(6) * ValuationFormulas(7) * ValuationFormulas(8) * ValuationFormulas(9) * ValuationFormulas(10) * ValuationFormulas(11) * ValuationFormulas(12) * ValuationFormulas(13) * ValuationFormulas(14) * ValuationFormulas(15) * ValuationFormulas(16) * ValuationFormulas(17) * ValuationFormulas(18) * ValuationFormulas(19) * ValuationFormulas(20) * ValuationFormulas(21) * ValuationFormulas(22) * ValuationFormulas(23) * ValuationFormulas(24) * ValuationFormulas(25) * ValuationFormulas(26) * ValuationFormulas(27) * ValuationFormulas(28) * ValuationFormulas(29) * ValuationFormulas(30) * ValuationFormulas(31) * ValuationFormulas(32) * ValuationFormulas(33) * ValuationFormulas(34) * ValuationFormulas(35) * ValuationFormulas(36) * ValuationFormulas(37) * ValuationFormulas(38) * ValuationFormulas(39) * ValuationFormulas(40) * ValuationFormulas(41) * ValuationFormulas(42)
Valuation2 = ValuationFormulas(43) * ValuationFormulas(44) * ValuationFormulas(45) * ValuationFormulas(46) * ValuationFormulas(47) * ValuationFormulas(48) * ValuationFormulas(49) * ValuationFormulas(50) * ValuationFormulas(51) * ValuationFormulas(52) * ValuationFormulas(53) * ValuationFormulas(54) * ValuationFormulas(55) * ValuationFormulas(56) * ValuationFormulas(57) * ValuationFormulas(58)
Valuation = (Valuation1 * Valuation2) / 0.001
ValuationTable(ThisCount) = Valuation
'MsgBox ValuationTable(ThisCount)
End If
Next

'Create Valuation Difference, Aggregate, Minimum and Refined return Array
ArrayCount = 0

For ThatCount = 4 To RefFinalRow + 1 Step 3

'Define Valuation Columns
ValDiff = (ValuationTable(ThatCount + 1) - ValuationTable(ThatCount)) / ValuationTable(ThatCount)
ValMin = wb.Sheets("Data").Range("K" & ThatCount).Value
AggVal = wb.Sheets("Data").Range("M" & ThatCount).Value
RefRet = Evaluate("IFERROR(IF(" & ValDiff & "<0," & AggVal & ",IF(" & ValDiff & "<" & ValMin & ",((" & ValMin & "-" & ValDiff & ")/" & ValMin & ")*" & AggVal & ",0))," & Chr(34) & "-" & Chr(34) & ")")

'Populate Array
ReDim Preserve ValuationArray(4, ArrayCount)
ValuationArray(0, ArrayCount) = ValDiff
ValuationArray(1, ArrayCount) = ValMin
ValuationArray(2, ArrayCount) = AggVal
ValuationArray(3, ArrayCount) = RefRet
ValuationArray(4, ArrayCount) = ThatCount

ArrayCount = ArrayCount + 1
Next

'Calculate Sum of Aggregate Return
With Application.WorksheetFunction
   TotAggSum = .Sum(.Index(ValuationArray, 3, 0))
End With

'Calculate Sum of refined Return
With Application.WorksheetFunction
   TotRefRet = .Sum(.Index(ValuationArray, 4, 0))
End With

'-------------------<<<<Define Factor Value Arrays>>>>>------------
ArrayCount = 0

For FactorMatchColNum = 21 To 79
If FactorMatchColNum <> 27 Then

FactorMatchCol = Split(Cells(1, FactorMatchColNum).Address, "$")(1)

'Define Factor Columns
FactorColNum = WorksheetFunction.Match(Sheets("Data").Range(FactorMatchCol & "2").Value, wb.Sheets("Data").Range("CB2:" & RefLastCol & "2"), 0) + 79
FactorValCol = Split(Cells(1, FactorColNum).Address, "$")(1)
FactorValWCol = Split(Cells(1, FactorColNum + 1).Address, "$")(1)
FactorValAWCol = Split(Cells(1, FactorColNum + 2).Address, "$")(1)
FactorName = wb.Sheets("Data").Range(FactorValCol & "2").Value

For AnotherCount = 6 To RefFinalRow + 1 Step 3

FactorValDiff = wb.Sheets("Data").Range(FactorValCol & AnotherCount).Value
FactorValWDiff = wb.Sheets("Data").Range(FactorValWCol & AnotherCount).Value

'Search for matching Refined Return multiplier in valuation array
For i = LBound(ValuationArray, 2) To UBound(ValuationArray, 2)
If ValuationArray(4, i) = AnotherCount - 2 Then
RemRet = (1 - (WorksheetFunction.RoundUp(ValuationArray(3, i), 0) / WorksheetFunction.RoundUp(ValuationArray(2, i), 0)))
Exit For
End If
Next

If RemRet <> 0 Then
FactorValAWDiff = FactorValWDiff * RemRet
Else: FactorValAWDiff = 0
End If

'Populate Array
ReDim Preserve FactorValueArray(4, ArrayCount)
FactorValueArray(0, ArrayCount) = FactorName
FactorValueArray(1, ArrayCount) = FactorValDiff
FactorValueArray(2, ArrayCount) = FactorValWDiff
FactorValueArray(3, ArrayCount) = FactorValAWDiff
FactorValueArray(4, ArrayCount) = AnotherCount

ArrayCount = ArrayCount + 1
Next
End If
Next

'-----<<<Define Factor Value Sum Array>>>>>--------

ArrayCount = 0

For FactorMatchColNum = 21 To 79
If FactorMatchColNum <> 27 Then

FactorMatchCol = Split(Cells(1, FactorMatchColNum).Address, "$")(1)

'Define Factor Columns
FactorColNum = WorksheetFunction.Match(Sheets("Data").Range(FactorMatchCol & "2").Value, wb.Sheets("Data").Range("CB2:" & RefLastCol & "2"), 0) + 79
FactorValCol = Split(Cells(1, FactorColNum).Address, "$")(1)
FactorValWCol = Split(Cells(1, FactorColNum + 1).Address, "$")(1)
FactorValAWCol = Split(Cells(1, FactorColNum + 2).Address, "$")(1)
FactorName = wb.Sheets("Data").Range(FactorValCol & "2").Value

FactorSum = 0
FactorWSum = 0
FactorAWSum = 0

For i = LBound(FactorValueArray, 2) To UBound(FactorValueArray, 2)
If FactorValueArray(0, i) = FactorName Then
FactorSum = FactorSum + FactorValueArray(1, i)
FactorWSum = FactorWSum + FactorValueArray(2, i)
FactorAWSum = FactorAWSum + FactorValueArray(3, i)
End If
Next

FactorComp = "N"

If FactorWSum > 0 And FactorAWSum > 0 Then
FactorComp = "Y"
End If
If FactorWSum < 0 And FactorAWSum < 0 Then
FactorComp = "Y"
End If

FactorABSVal = Abs(FactorAWSum)

FactorSignVal = 1

If FactorAWSum < 0 Then
FactorSignVal = -1
End If

'Populate Factor Value Sum Array
ReDim Preserve FactorValueSumArray(6, ArrayCount)
FactorValueSumArray(0, ArrayCount) = FactorName
FactorValueSumArray(1, ArrayCount) = FactorSum
FactorValueSumArray(2, ArrayCount) = FactorWSum
FactorValueSumArray(3, ArrayCount) = FactorAWSum
FactorValueSumArray(4, ArrayCount) = FactorABSVal
FactorValueSumArray(5, ArrayCount) = FactorComp
FactorValueSumArray(6, ArrayCount) = FactorSignVal

ArrayCount = ArrayCount + 1
End If
Next
'With Application.WorksheetFunction
   'DSum = .SumProduct(.Index(FactorValueArray, 1, 0), .Index(FactorValueArray, 1, 0) = FactorName)
'End With

'TotRefRet = DSum

'CompVal = WorksheetFunction.Large(FactorValueSumArray(4, 0), 1)

'CompVal = WorksheetFunction.Large(FactorValueSumArray(4, 0), 1)

'Find First Comp Factor
ValCheck = 0
FactorCheck = "-"
SignCheck = 1
FactorVal = 0
'PrevFirstCompFactor = FirstCompFactor
For i = LBound(FactorValueSumArray, 2) To UBound(FactorValueSumArray, 2)
If FactorValueSumArray(4, i) > ValCheck And FactorValueSumArray(5, i) = "Y" Then
ValCheck = FactorValueSumArray(4, i)
FactorCheck = FactorValueSumArray(0, i)
SignCheck = FactorValueSumArray(6, i)
FactorVal = FactorValueSumArray(3, i)
End If
Next

CompVal = FactorVal
FirstCompFactor = FactorCheck
FirstCompFactorSign = SignCheck

'Find Second Comp Factor
ValCheck = 0
FactorCheck = "-"
SignCheck = 1
FactorVal = 0
For i = LBound(FactorValueSumArray, 2) To UBound(FactorValueSumArray, 2)
If FactorValueSumArray(4, i) > ValCheck And FactorValueSumArray(4, i) < CompVal And FactorValueSumArray(5, i) = "Y" Then
ValCheck = FactorValueSumArray(4, i)
FactorCheck = FactorValueSumArray(0, i)
SignCheck = FactorValueSumArray(6, i)
FactorVal = FactorValueSumArray(3, i)
End If
Next

CompVal2 = FactorVal
SecondCompFactor = FactorCheck
SecondCompFactorSign = SignCheck

'-------

If FirstCompFactor = "-" Then
Exit For
End If

If FirstCompFactor = PrevFirstCompFactor Then
If PrevFirstCompFactorSign <> FirstCompFactorSign Then
If SecondCompFactor <> "-" Then
FirstCompFactor = SecondCompFactor
Else: Exit For
End If
FirstCompFactorSign = SecondCompFactorSign
End If
End If

PrevFirstCompFactor = FirstCompFactor
PrevFirstCompFactorSign = FirstCompFactorSign

'Update Factor Value in Valuation Table Array
For i = LBound(ValuationTableArray, 2) To UBound(ValuationTableArray, 2)
If ValuationTableArray(0, i) = FirstCompFactor And ValuationTableArray(2, i) = IndustryString Then
If FirstCompFactorSign > 0 Then
ValuationTableArray(1, i) = ValuationTableArray(1, i) - 0.5
Else
ValuationTableArray(1, i) = ValuationTableArray(1, i) + 0.5
End If
End If

Next

Next

Application.Calculation = xlAutomatic

End Sub

I advise you to check often what is more profitable. Whether using a spreadsheet function or a typical VBA solution. Although it is generally said that spreadsheet functions are fast, this is not always the case. Proof below.
There are still a few things to optimize in the code, but I think MOD is your main problem.

Sub AAA()
    Dim i As Long, j As Long
    Dim Tm1 As Single, Tm2 As Single, Tm3 As Single

    Tm1 = Timer

    For i = 1 To 50
        For j = 1 To 3000

            If Evaluate("Mod(" & j & ",3)") <> 0 Then
            End If

        Next j
    Next i

    Tm2 = Timer

    For i = 1 To 50
        For j = 1 To 3000

            If j Mod 3 <> 0 Then
            End If

        Next j
    Next i

    Tm3 = Timer

    Debug.Print String(30, "-")
    Debug.Print "First loop: " & Format(Tm2 - Tm1, "0.0000")
    Debug.Print "Second loop: " & Format(Tm3 - Tm2, "0.0000")
    Debug.Print "I.e. " & Round((Tm2 - Tm1) / (Tm3 - Tm2), 0) & " times faster!"
End Sub

Artik

There are a few things that can be done to speed up the code, but as @JohnTopley suggested, a sample workbook would be recommended for testing on.