2
\$\begingroup\$

My code below is used as a back testing tool to review a past Daily Fantasy Sports slate. This code works perfectly but when the contest size (total entrants) gets up to the 30,000 range it takes quite a long time, and I don't even attempt to review a slate that is 100,000 entrants. I would like some advice on how to speed it up. I referenced an example of a small slate as an example to look at while examining the code.

Small Slate

Option Explicit

Sub Backtesting_NBA_Classic()

Application.ScreenUpdating = False

'Finds the always changing folder name
Dim strPath As String
strPath = Dir("C:\Users\safo2\downloads\Contest*", vbDirectory)

'Find the path of the folder
Dim strPath1 As String
strPath1 = "C:\Users\safo2\downloads\" & strPath & "\"

'Opens the CSV
Dim strName As String
strName = Dir(strPath1 & "contest*.csv")
Workbooks.Open (strPath1 & strName)

'Declares the CSV Workbook and names Sheet1
Dim wbBacktesting As Workbook
Set wbBacktesting = Workbooks(strName)
wbBacktesting.Sheets(1).Name = "Sheet1"

'Declares Sheet1
Dim wsSheet1 As Worksheet
Set wsSheet1 = wbBacktesting.Sheets("Sheet1")

'Add columns
Dim rngG_M As Range
Set rngG_M = wsSheet1.Range("G:M")
rngG_M.Insert Shift:=xlToRight, copyorigin:=xlFormatFromLeftOrAbove

'Removed positions from each lineup
Dim rngF As Range
Set rngF = wsSheet1.Range("F:F")
With rngF
    .Replace what:=" PG ", replacement:=",", lookat:=xlPart, MatchCase:=True
    .Replace what:=" SG ", replacement:=",", lookat:=xlPart, MatchCase:=True
    .Replace what:=" SF ", replacement:=",", lookat:=xlPart, MatchCase:=True
    .Replace what:=" PF ", replacement:=",", lookat:=xlPart, MatchCase:=True
    .Replace what:=" F ", replacement:=",", lookat:=xlPart, MatchCase:=True
    .Replace what:=" G ", replacement:=",", lookat:=xlPart, MatchCase:=True
    .Replace what:=" C ", replacement:=",", lookat:=xlPart, MatchCase:=True
    .Replace what:=" UTIL ", replacement:=",", lookat:=xlPart, MatchCase:=True
    .Replace what:="PG ", replacement:="", lookat:=xlPart, MatchCase:=True
    .Replace what:="SG ", replacement:="", lookat:=xlPart, MatchCase:=True
    .Replace what:="SF ", replacement:="", lookat:=xlPart, MatchCase:=True
    .Replace what:="PF ", replacement:="", lookat:=xlPart, MatchCase:=True
    .Replace what:="F ", replacement:="", lookat:=xlPart, MatchCase:=True
    .Replace what:="G ", replacement:="", lookat:=xlPart, MatchCase:=True
    .Replace what:="C ", replacement:="", lookat:=xlPart, MatchCase:=True
    .Replace what:="UTIL ", replacement:="", lookat:=xlPart, MatchCase:=True
    .Cells.EntireColumn.AutoFit
    .TextToColumns Destination:=Range("F1"), DataType:=xlDelimited, _
        TextQualifier:=xlDoubleQuote, ConsecutiveDelimiter:=False, Tab:=False, _
        Semicolon:=False, Comma:=True, Space:=False, Other:=False, FieldInfo _
        :=Array(Array(1, 1), Array(2, 1), Array(3, 1), Array(4, 1), Array(5, 1), Array(6, 1), _
        Array(7, 1), Array(8, 1)), TrailingMinusNumbers:=True
End With

'Declares a range of the whole Sheet1 and autfits the whole sheet
Dim rngAll As Range
Set rngAll = wsSheet1.Range("A:S")
rngAll.Cells.EntireColumn.AutoFit

'Find and Replace incorrect player names
rngAll.Replace what:="OAnunoby", replacement:="OG Anunoby", lookat:=xlPart _
        , SearchOrder:=xlByRows, MatchCase:=True, SearchFormat:=False, _
        ReplaceFormat:=False, FormulaVersion:=xlReplaceFormula2

'Add player identifier
Dim Lastrow As Variant
Lastrow = wsSheet1.Range("R" & wsSheet1.Rows.Count).End(xlUp).Row
Dim rngAutofillSource As Range
Dim rngAutofillDestination As Range
Set rngAutofillSource = wsSheet1.Range("S2:S3")
Set rngAutofillDestination = wsSheet1.Range("S2", "S" & Lastrow)
wsSheet1.Range("S1") = "Identification"
wsSheet1.Range("S2") = "1"
wsSheet1.Range("S3") = "2"
rngAutofillSource.AutoFill Destination:=rngAutofillDestination

'Add Sheet 2 to find duplicates
Dim objSheet As Object
Set objSheet = wbBacktesting.Sheets.Add(after:=Sheet1)
objSheet.Name = "Sheet2"
Dim wsSheet2 As Worksheet
Set wsSheet2 = wbBacktesting.Sheets("Sheet2")

'Add headers to the Player ID columns & vlookup the player name for the ID
With wsSheet2
    .Range("A1") = "Player 1"
    .Range("B1") = "Player 2"
    .Range("C1") = "Player 3"
    .Range("D1") = "Player 4"
    .Range("E1") = "Player 5"
    .Range("F1") = "Player 6"
    .Range("G1") = "Player 7"
    .Range("H1") = "Player 8"
    .Range("A2") = "=VLOOKUP(Sheet1!F2,Sheet1!$O$2:$S$500,5,FALSE)"
    .Range("B2") = "=VLOOKUP(Sheet1!G2,Sheet1!$O$2:$S$500,5,FALSE)"
End With

'Autofill the Player ID's from left to right
Dim rngAutofillSource2 As Range
Dim rngAutofillDestination2 As Range
Set rngAutofillSource2 = wsSheet2.Range("A2:B2")
Set rngAutofillDestination2 = wsSheet2.Range("A2:H2")
rngAutofillSource2.AutoFill Destination:=rngAutofillDestination2

'Find the last row with a lineup
Dim Lastrow2 As Variant
Lastrow2 = wsSheet1.Range("F" & wsSheet1.Rows.Count).End(xlUp).Row

'Autofill Column A to the last Player ID
Dim rngAutofillSource3 As Range
Dim rngAutofillDestination3 As Range
Set rngAutofillSource3 = wsSheet2.Range("A2")
Set rngAutofillDestination3 = wsSheet2.Range("A2", "A" & Lastrow2)
rngAutofillSource3.AutoFill Destination:=rngAutofillDestination3

'Autofill Column B to the last Player ID
Dim rngAutofillSource4 As Range
Dim rngAutofillDestination4 As Range
Set rngAutofillSource4 = wsSheet2.Range("B2")
Set rngAutofillDestination4 = wsSheet2.Range("B2", "B" & Lastrow2)
rngAutofillSource4.AutoFill Destination:=rngAutofillDestination4

'Autofill Column C to the last Player ID
Dim rngAutofillSource5 As Range
Dim rngAutofillDestination5 As Range
Set rngAutofillSource5 = wsSheet2.Range("C2")
Set rngAutofillDestination5 = wsSheet2.Range("C2", "C" & Lastrow2)
rngAutofillSource5.AutoFill Destination:=rngAutofillDestination5

'Autofill Column D to the last Player ID
Dim rngAutofillSource6 As Range
Dim rngAutofillDestination6 As Range
Set rngAutofillSource6 = wsSheet2.Range("D2")
Set rngAutofillDestination6 = wsSheet2.Range("D2", "D" & Lastrow2)
rngAutofillSource6.AutoFill Destination:=rngAutofillDestination6

'Autofill Column E to the last Player ID
Dim rngAutofillSource7 As Range
Dim rngAutofillDestination7 As Range
Set rngAutofillSource7 = wsSheet2.Range("E2")
Set rngAutofillDestination7 = wsSheet2.Range("E2", "E" & Lastrow2)
rngAutofillSource7.AutoFill Destination:=rngAutofillDestination7

'Autofill Column F to the last Player ID
Dim rngAutofillSource8 As Range
Dim rngAutofillDestination8 As Range
Set rngAutofillSource8 = wsSheet2.Range("F2")
Set rngAutofillDestination8 = wsSheet2.Range("F2", "F" & Lastrow2)
rngAutofillSource8.AutoFill Destination:=rngAutofillDestination8

'Autofill Column G to the last Player ID
Dim rngAutofillSource9 As Range
Dim rngAutofillDestination9 As Range
Set rngAutofillSource9 = wsSheet2.Range("G2")
Set rngAutofillDestination9 = wsSheet2.Range("G2", "G" & Lastrow2)
rngAutofillSource9.AutoFill Destination:=rngAutofillDestination9

'Autofill Column H to the last Player ID
Dim rngAutofillSource10 As Range
Dim rngAutofillDestination10 As Range
Set rngAutofillSource10 = wsSheet2.Range("H2")
Set rngAutofillDestination10 = wsSheet2.Range("H2", "H" & Lastrow2)
rngAutofillSource10.AutoFill Destination:=rngAutofillDestination10

'Sort each row from smallest Player ID to the largest Player ID
Dim rngSortRange2 As Range
Dim Counter As Variant
For Counter = 2 To Lastrow2
    wsSheet2.Range("A" & Counter, "H" & Counter).Sort _
        Key1:=wsSheet2.Range("A" & Counter, "H" & Counter).Columns(1), _
        Header:=xlYes, _
        Orientation:=xlLeftToRight, _
        MatchCase:=False, _
        SortMethod:=xlPinYin
Next Counter

'Add headers for concatenating each row
wsSheet2.Range("I1") = "Concat"
wsSheet2.Range("I2") = "=CONCAT($A2:$H2)"
wsSheet2.Range("I3") = "=CONCAT($A3:$H3)"

'Autofill the concatenated row for all rows
Dim rngAutofillSource11 As Range
Dim rngAutofillDestination11 As Range
Set rngAutofillSource11 = wsSheet2.Range("I2")
Set rngAutofillDestination11 = wsSheet2.Range("I2", "I" & Lastrow2)
rngAutofillSource11.AutoFill Destination:=rngAutofillDestination11

'Add columns to copy data from Sheet1
Dim rngA_E As Range
Set rngA_E = wsSheet2.Range("A:E")
rngA_E.Insert Shift:=xlToRight, copyorigin:=xlFormatFromLeftOrAbove

'Copy data from Sheet 1 to Sheet 2
Dim rngSheet1toSheet2 As Range
Set rngSheet1toSheet2 = wsSheet1.Range("A:E")
rngSheet1toSheet2.Copy wsSheet2.Range("A:E")

'Conditional Formatting
Dim rngColumnN As Range
Set rngColumnN = wsSheet2.Range("N:N")
rngColumnN.FormatConditions.AddUniqueValues
rngColumnN.FormatConditions(rngColumnN.FormatConditions.Count).SetFirstPriority
rngColumnN.FormatConditions(1).DupeUnique = xlDuplicate
With rngColumnN.FormatConditions(1).Font
    .Color = -16383844
    .TintAndShade = 0
End With
With rngColumnN.FormatConditions(1).Interior
    .PatternColorIndex = xlAutomatic
    .Color = 13551615
    .TintAndShade = 0
End With
rngColumnN.FormatConditions(1).StopIfTrue = False

'Autofilter
Dim rngAll2 As Range
Set rngAll2 = wsSheet2.Range("A:N")
rngAll2.AutoFilter
rngAll2.Cells.EntireColumn.AutoFit
    
End Sub
\$\endgroup\$

1 Answer 1

Reset to default
1
\$\begingroup\$

You have a lot of rows that contains formulas which gets calculated each time something on the sheet is changed.

A good practice in addition to using Application.ScreenUpdating = False is to also use Application.Calculation = xlCalculationManual so that the formulas don't get calculated until you allow it to be calculated.

Ideally you'd want to save the initial calculation mode so that you can change it back to what it was previously.

initialMode = Application.Calculation 'save calculation mode
Application.Calculation = xlCalculationManual

'Do something

Application.Calculation = initialMode
\$\endgroup\$
7
  • \$\begingroup\$ Interesting, I will give this a try. What do I declare "Initial Mode" as? \$\endgroup\$ Commented Feb 27, 2023 at 16:39
  • \$\begingroup\$ You can declare it as ‘Integer’ \$\endgroup\$ Commented Feb 27, 2023 at 20:05
  • \$\begingroup\$ @safo2238 Better to declare As XLCalculation (if you put your Cursor inside the Calculation word and press Ctrl+i it shows basic information, Ctrl+F2 shows the extended definition in the object browser). Integer is 16 bits but XLCalculation is 32 bits. You can also declare As Long which is 32 bits. As Integer is very rarely the best way to go: stackoverflow.com/a/26409520/6609896 \$\endgroup\$ Commented Feb 28, 2023 at 11:07
  • \$\begingroup\$ Wow, I did not know those Ctrl features, that is so helpful. I will give this a try, thanks. \$\endgroup\$ Commented Feb 28, 2023 at 22:38
  • \$\begingroup\$ For Counter = 2 To Lastrow2 wsSheet2.Range("A" & Counter, "H" & Counter).Sort _ key1:=wsSheet2.Range("A" & Counter, "H" & Counter).Columns(1), _ Header:=xlYes, _ Orientation:=xlLeftToRight, _ MatchCase:=False, _ SortMethod:=xlPinYin Next Counter Is there a quicker way to sort than this? This is the part of the code that takes so long. \$\endgroup\$ Commented Mar 3, 2023 at 14:49

You must log in to answer this question.

Start asking to get answers

Find the answer to your question by asking.

Ask question

Explore related questions

See similar questions with these tags.