VBA code used to build a diverse portfolio of DFS lineups to minimize risk

Question

This code works great and does exactly what I want but it takes around 10 minutes for the code for find 150 lineups. I am hoping to get help and learn how to make it much faster.

The goal of this code is as follows:

1. Search for each playerid in the wsbuild.Range("C2:J5001")
2. The first time it is found add each playerid to the dictionary
3. Then cut the lineup to rw.Cut Destination:=wsLineups.Cells(Rows.count, "A").End(xlUp).Offset(1)
4. Once the lineup has been cut, count the number of times each playerid shows up in the range on wslineups. If a playerid quantity is the same as the For count = 2 To HowManyLineups + 1 loop then I don't want to use it because the goal is to get a diverse set of lineups and not use the same players too often. Cut the lineup back to its original position on wsbuild.
5. If the cut lineup had all original players then keep it and move on to the next C.
6. Once I have looped through all playerids then remove all playerids from the dictionary and start over until If IsEmpty(Check) = False Then Exit For the desired number of lineups has been met.

Here is the code:

Option Explicit
Sub MLB_Step_2()
'Turn off screen updating
Application.ScreenUpdating = False
'Define Macros workbook
Dim wbMacros As Workbook
Set wbMacros = Workbooks("Classic_Slates_Custom_Sum.xlsm")
'Define Dictionary
Dim dict As Object
Set dict = CreateObject("scripting.dictionary")
'Define wsData
Dim wsData As Worksheet
Set wsData = ThisWorkbook.Worksheets("Data")
'Define wsBuild
Dim wsbuild As Worksheet
Set wsbuild = ThisWorkbook.Worksheets("Build")
'Define wsLineups
Dim wsLineups As Worksheet
Set wsLineups = ThisWorkbook.Worksheets("Lineups")
'Define Lastrow
Dim Lastrow As Integer
'Define rngCheck
Dim Check As Range
Dim C As Range
'Search for each playerid in the lineups range
Dim count As Integer
For count = 2 To HowManyLineups + 1
 Set Check = wsLineups.Range("A" & (HowManyLineups / 2) + 1)
 For Each C In wsData.Range("Q2", wsData.Cells(Rows.count, "Q").End(xlUp))
 Dim v As Long
 v = C.Value
 If dict.exists(CStr(v)) Then
 C.Interior.Color = vbYellow
 Else
 Dim f As Range
 Set f = wsbuild.Range("C2:J5001").Find(v, Lookat:=xlWhole, LookIn:=xlValues, searchorder:=xlByRows)
 If Not f Is Nothing Then
 Dim rngrow As Integer
 rngrow = f.row
 Dim rw As Range
 Set rw = f.EntireRow.Columns("A").Resize(1, 10)
 Dim c2 As Range
 For Each c2 In rw.Cells
 dict(CStr(c2)) = True
 Next c2
 Set rw = f.EntireRow.Columns("A").Resize(1, 37)
 
 'Cut the found lineup and paste to wsLineups
 rw.Cut Destination:=wsLineups.Cells(Rows.count, "A").End(xlUp).Offset(1)
 
 Lastrow = wsLineups.Range("AN" & wsLineups.Rows.count).End(xlUp).row
 
 C.Interior.Color = vbYellow
 
 Dim cell As Range
 
 'If the quantity of each player is equal to the count loop then cut the lineups back to its original place on wsbulid
 For Each cell In wsLineups.Range("AN2", "AN" & Lastrow)
 If cell.Value = count Then
 Lastrow = wsLineups.Range("A" & wsLineups.Rows.count).End(xlUp).row
 wsLineups.Range("A" & Lastrow, "AK" & Lastrow).Cut wsbuild.Range("A" & rngrow)
 If wsbuild.Range("A" & rngrow) <> "" Then Exit For
 Else
 End If
 Next cell
 Else
 C.Interior.Color = vbRed
 End If
 
 End If
 Set Check = wsLineups.Range("A" & (HowManyLineups / 2) + 1)
 If IsEmpty(Check) = False Then Exit For
 
 Next C
 wsData.Range("Q:Q").Interior.Color = xlNone
 If IsEmpty(Check) = False Then Exit For
 dict.RemoveAll
Next count
'Autofit columns
wsLineups.Range("A:AJ").EntireColumn.AutoFit
End Sub

Here is images of each tab for visual help understand the code.

wsdata tab

wsbuild tab

wslineups tab

• TinMan: If you provide a download link for the workbook, I'll look at it. Application.Calculation = xlCalculationManual may help. Ideally, you should do all the work in Arrays. Iterating over cells, cutting them and formatting them isn't ideal. I strategy to replace the formatting with Conditional Formatting would be better.
• safo2238: @TinMan What is the best/approved way to provide you a download link?
• safo2238: @TinMan 1drv.ms/u/s!Au1-g32xnKtH2VB8dB7HJXy509i6?e=cdy9AT Let me know if this works!

Answer 1

Worksheet.CodeName

Read: Excel VBA Tutorial: Unlock the Secrets of Worksheet Code Names

Using CodeNames for worksheets in VBA significantly enhances code reliability and readability. Since CodeName refers to the internal identifier of a worksheet, it remains constant even if the sheet's name changes or is moved by the user. This eliminates the risk of runtime errors due to accidental renaming or reordering of sheets. Additionally, referencing a worksheet by CodeName simplifies the code because it removes the need to repeatedly refer to the Workbook and Worksheet objects, making the code cleaner and easier to maintain. Ultimately, using CodeNames leads to more robust and user-proof macros.

Set wsData = ThisWorkbook.Worksheets("Data") These declarations can be removed across all the modules by changing the Worksheet CodeNames. Once the codename for Sheet1 is changed to wsData, wsData will always refer to the wsData in ThisWorkbook.

Changing Worksheet CodeName

I have noticed references to other Macro Workbooks in other modules. Here is a helper function that will return a reference to a Worksheet in an external Workbook by CodeName.

Function GetExternalWorkSheetByCodeName(Workbook As Workbook, CodeName As String) As Worksheet
 Dim Worksheet As Worksheet
 
 For Each Worksheet In Workbook.Worksheets
 If Worksheet.[_CodeName] = CodeName Then
 Set GetExternalWorkSheetByCodeName = Worksheet
 End If
 Next
End Function
Sub Example()
 Dim wbMacros As Workbook
 Set wbMacros = Workbooks("Classic_Slates.xlsm")
 Dim wsClassicData As Worksheet
 Set wsClassicData = GetExternalWorkSheetByCodeName(wbMacros, "wsData ")
End Sub

Performance

MLB_Step_2() took 129.9375 seconds to run on my machine. During that time it made 1017 cuts that had to be cut back to their original positions. TestCuts() took 74.3447265625 seconds to perform 1017 cuts. Roughly 57% of the runtime could be saved by reworking the logic, so that, the Player ID counts are checked against the Exposures before any cuts are made.

Sub TestCuts()
 Application.ScreenUpdating = False
 Dim t As Double: t = Timer
 Dim n As Long
 
 For n = 1 To 1017
 Range("A2").Resize(1, 37).Cut Range("AA2")
 Range("AA2").Resize(1, 37).Cut Range("A2")
 Next
 
 Debug.Print Timer - t
End Sub

Performing the counts using a Scripting.Dictionary and changing the logic to check the Player Id keys to be added to the lineup is at least one less the current count increment before cutting the cells would greatly improve the run time. In this way, you could Application.Calculation = xlCalculationManual which would be even more efficient.

Here are some functions I wrote that should help in refactoring the code. The Keys would be the Player IDs from rw e.g. Set rw = f.EntireRow.Columns("A").Resize(1, 10): Keys = rw.Value)

Function GetDFSDictionary(ws As Worksheet) As Object
 Dim Dict As Object
 Set Dict = CreateObject("Scripting.Dictionary")
 Dim Data As Variant
 With ws
 Data = .Range("AN2", Cells(Rows.Count, "AM").End(xlUp)).Value
 End With
 Dim r As Long
 Dim Key As String
 For r = 1 To UBound(Data)
 Key = Data(r, 1)
 If Not Dict.Exists(Key) Then Dict.Add Key, Data(r, 2)
 Next
 
 Set GetDFSDictionary = Dict
End Function
Function FSDictionaryValidateCount(Dict As Object, Count As Long, Keys As Variant) As Boolean
 Dim r As Long
 Dim Key As String
 For r = 1 To UBound(Keys)
 Key = Keys(r, 1)
 If Dict.Exists(Key) Then 
 Rem - 1 is used because we want to do the checks before we Cut the cells. 
 If Dict(Key) > Count - 1 Then Exit Function
 End If
 Next
 FSDictionaryValidateCount = True
End Function
Function FSDictionaryIncrementKeyValues(Dict As Object, Keys As Variant)
 Dim r As Long
 Dim Key As String
 For r = 1 To UBound(Keys)
 Key = Keys(r, 1)
 If Dict.Exists(Key) Then
 Dict(Key) = 1
 Else
 Debug.Print Key; " not found"
 End If
 Next
End Function

Ideally

You should do all the work in memory using Arrays and Dictionaries and write the data back once to update the Build and once to update the Line Up. This would probably be at least 30-50 times faster than the current code.

Refactored Code

KeyCounter Class Option Explicit

Public Dictionary As New Scripting.Dictionary
Public Sub IncrementKeys(ByRef Keys As Variant)
 Dim Key As Variant
 For Each Key In Keys
 If Dictionary.Exists(CStr(Key)) Then
 Dictionary(CStr(Key)) = Dictionary(CStr(Key)) + 1
 Else
 Dictionary(CStr(Key)) = 1
 End If
 Next
End Sub
 
Public Sub DecrementKeys(ByRef Keys As Variant)
 Dim Key As Variant
 For Each Key In Keys
 Dictionary(CStr(Key)) = Dictionary(CStr(Key)) - 1
 Next
End Sub
 
Function MaxKeyCount()
 Dim Key As Variant
 Dim Max As Long
 
 For Each Key In Dictionary
 If Dictionary(CStr(Key)) > Max Then
 Max = Dictionary(CStr(Key))
 End If
 Next
 MaxKeyCount = Max
End Function

BuildData

Option Explicit
Public Data As Variant
Public BuildDataRanage As Range
Public Cursor As Long
Private Const FirstKeyColumn As Long = 3
Private Const LastKeyColumn As Long = 10
Private Const LastDataColumn As Long = 37
Private Sub Class_Initialize()
 With ThisWorkbook.Worksheets("Build")
 Set BuildDataRanage = .Range("A2", .Cells(Rows.Count, 1).End(xlUp)).Resize(, LastDataColumn)
 End With
 Data = BuildDataRanage.value
End Sub
Function GotoKey(Key As Variant) As Boolean
 Dim r As Long, c As Long
 Dim LineUp(1 To LastKeyColumn) As Variant
 For r = 1 To UBound(Data)
 For c = 1 To LastKeyColumn
 If Data(r, c) = Key Then
 Cursor = r
 GotoKey = True
 Exit Function
 End If
 Next
 Next
End Function
Function GetCurrentKeys()
 Dim c As Long
 Dim LineUp(FirstKeyColumn To LastKeyColumn) As Variant
 For c = FirstKeyColumn To LastKeyColumn
 LineUp(c) = Data(Cursor, c)
 Next
 
 GetCurrentKeys = LineUp
End Function
Function GetRow(Optional EraseRow As Boolean = True) As Variant
 Dim c As Long
 Dim LineUp(1 To LastDataColumn) As Variant
 For c = 1 To LastDataColumn
 LineUp(c) = Data(Cursor, c)
 If EraseRow Then Data(Cursor, c) = ""
 Next
 GetRow = LineUp
End Function
Function UpdateBuild()
 BuildDataRanage = Data
End Function

Refactored MLB_Step_2

Place this in a standard module.

Option Explicit
Sub MLB_Step_2A(CountOfLineUps As Long)
 Const NumberOfKeys As Long = 10
 Const LastDataColumn As Long = 37
 Dim Lineups As Variant
 ReDim Lineups(1 To CountOfLineUps, 1 To LastDataColumn)
 
 Dim t As Double: t = Timer
 'Turn off screen updating
 Application.ScreenUpdating = False
 'Define wsLineups
 Dim wsLineups As Worksheet
 Set wsLineups = ThisWorkbook.Worksheets("Lineups")
 Dim Keys As Variant, Key As Variant
 With wsLineups
 Keys = .Range("AM2", .Cells(Rows.Count, "AM").End(xlUp)).value
 .UsedRange.Columns("A:AL").Offset(1).ClearContents
 End With
 
 Dim DataClass As New BuildData
 Dim Counter As New KeyCounter
 Dim Dict As Scripting.Dictionary
 Set Dict = CreateObject("Scripting.Dictionary")
 
 Dim NewKeys As Variant
 Dim LineUp As Variant
 Dim Pass As Long
 Dim Count As Long
 Dim r As Long, c As Long
 Pass = 1
 Dim Its As Long
 
 Do
 Pass = Pass + 1
 For Each Key In Keys
 If Not Dict.Exists(CStr(Key)) Then
 If DataClass.GotoKey(Key) Then
 NewKeys = DataClass.GetCurrentKeys()
 Dim Key2 As Variant
 For Each Key2 In NewKeys
 Dict(CStr(Key2)) = True
 Next
 
 Counter.IncrementKeys NewKeys
 If Counter.MaxKeyCount = Pass Then
 Counter.DecrementKeys NewKeys
 ElseIf Counter.MaxKeyCount > Pass Then
 Stop
 Else
 Count = Count + 1
 LineUp = DataClass.GetRow(True)
 For c = 1 To LastDataColumn
 Lineups(Count, c) = LineUp(c)
 Next
 If Count = CountOfLineUps Then Exit Do
 End If
 Else
 Debug.Print Key; " not found"
 End If
 End If
 Next
 
 Dict.RemoveAll
 Loop While Pass < 500 'This is a safeguard and should never trigger
 
 wsLineups.Range("A:AJ").EntireColumn.AutoFit
 
 With wsLineups
 .Range("A2").Resize(CountOfLineUps, LastDataColumn).value = Lineups
 .Columns.AutoFit
 End With
 
 DataClass.UpdateBuild
 
 Debug.Print Timer - t
End Sub

Usage Pass in the actual number of expected Line Ups

MLB_Step_2A 75

Performance MLB_Step_2: 117.1591796875 seconds MLB_Step_2A 75: 0.5625 seconds MLB_Step_2A was 208 times faster than the original code.

Notes

I added a reference to the Microsoft Scripting Runtime for early Dictionary binding and so that I can take advantage of Intellisense.

• safo2238: "Here are some functions I wrote that should help in refactoring the code. The Keys would be the Player IDs from rw e.g. Set rw = f.EntireRow.Columns("A").Resize(1, 10): Keys = rw.Value)" Where would I define this? I have not wrapped my head around arrays yet. This is very helpful, thank you.
• TinMan: @safo2238 Using arrays, I got the runtime to ~1 sec down from ~111 secs but I'm having the damndest time getting the results to match, as expected. I'll look at it again tomorrow.
• safo2238: Please let me know how I can help, and I appreciate the persistence.
• TinMan: @safo2238 It was a simple fix. I didn't realize that the Exposure count skipped the first 2 columns. The results now match. Let me know if you need help implementing my refactored code.
• safo2238: Where do I put the BuildData and KeyCounter Class? I have been trying to implement this morning and struggling.