Option Explicit
Public EventState As Boolean
Public PageBreakState As Boolean
Public CalcState As Long
Private Sub OptimizeCode_Begin()
'
With Application
CalcState = .Calculation
EventState = .EnableEvents
PageBreakState = ActiveSheet.DisplayPageBreaks
'
.StatusBar = False
.Calculation = xlManual
.EnableEvents = False
.ScreenUpdating = False
ActiveSheet.DisplayPageBreaks = False
End With
End Sub
Private Sub OptimizeCode_End()
'
With Application
ActiveSheet.DisplayPageBreaks = PageBreakState
.EnableEvents = EventState
.Calculation = CalcState
'
.ScreenUpdating = True
.StatusBar = False
End With
End Sub
Sub NameCombosV24b()
'https://www.mrexcel.com/forum/excel-questions/1106189-all-combinations-multiple-columns-without-duplicates.html
'
Dim bFoundSalary As Boolean
Dim bShowError As Boolean
Dim ComboID_Display As Boolean
Dim dteStart As Date
Dim StartTime As Date
Dim ArrayRow As Long, ArrayColumn As Long
Dim ColumnA_Row As Long, ColumnB_Row As Long, ColumnC_Row As Long
Dim ColumnD_Row As Long, ColumnE_Row As Long, ColumnF_Row As Long
Dim ColumnG_Row As Long, ColumnH_Row As Long, ColumnI_Row As Long
Dim CurrentRow As Long, NoDupeRow As Long, NoDupeRow2 As Long
Dim ExcessCombinations As Long
Dim lLastRow As Long
Dim lFirstHSortColumn As Long, lLastHSortColumn As Long
Dim lFirstHTeamCol As Long, lLastHTeamCol As Long
Dim lFirstWriteColumn As Long, lLastWriteColumn As Long
Dim lIterationCount As Long, lLastIteration As Long
Dim lLastColumn As Long, lLastUsedColumn As Long
Dim lLastSalaryRow As Long
Dim lWriteRow As Long
Dim MaxNoDupeRowArrayRows As Long
Dim MaxPasses As Long, PassNumber As Long
Dim MaxSalaryAllowed As Long
Dim SubArrayNumber As Long, SubArrays As Long
Dim SubArrayColumn As Long, SubArrayRow As Long
Dim SalarySheetShortenedArrayRow As Long, UniqueArrayRow As Long
Dim oSD As Object
Dim cel As Range
Dim rngFormulaRange As Range, rngSortRange As Range
Dim WorksheetNameRange As Range
Dim Delimiter As String, oSD_KeyString As String
Dim sMissingSalary As String
Dim aryNames As Variant
Dim JaggedArray() As Variant
Dim NamesAndComboIdArray As Variant
Dim NoDupeRowArray() As Variant
Dim NoDupeSortedRowsArray() As Variant
Dim SalarySheetFullArray As Variant, SalarySheetShortenedArray() As Variant
Dim TempArray As Variant, TempArray2 As Variant
Dim WorksheetNamesArray As Variant, UniqueWorksheetNamesArray As Variant
Dim WorksheetColumnArray() As Variant
Dim names As Worksheet, wks As Worksheet, wksData As Worksheet
'
Const LastIterationMultiplier As Single = 0.75 ' <--- Set this to the mutiply value of total possible combinations,
' ' this will be used for calculating the amount of
' ' rows to set the NamesAndComboIdArray to
Const MaxCombinationRows As Long = 200000 ' <--- Set the MaxCombinationRows (200000) is probaly the max to be generated at a time
Const MaxRowsPerSubArray As Long = 20000 ' <--- Set the MaxRowsPerSubArray (200000) is probaly the max you would want
'
ComboID_Display = True ' <--- Set this to True or False to see/not see the ComboID column
MaxSalaryAllowed = 60000 ' <--- set this value to what you want
'
'-------------------------------------------------------------------------------------------------------------------------------
'
Call OptimizeCode_Begin
'
Set wksData = ThisWorkbook.Sheets("Worksheet")
Set names = Sheets("Salary")
'
'-------------------------------------------------------------------------------------------------------------------------------
'
' 1) Take all the names entered on the "Worksheet" (A2:Ix) sheet and check to see if all of those names also have a salary listed on the "Salary" sheet.
' If any of the names from "Worksheet" are not on the "Salary" sheet, it ends Sub. If all the names are on the salary sheet and there are corresponding
' salaries for each of those names, a pop up box will appear letting you know how many combinations to expect.
'
'Check for salary worksheet
For Each wks In ThisWorkbook.Worksheets
If wks.Name = "Salary" Then bFoundSalary = True
Next
'
If Not bFoundSalary Then
MsgBox "The workbook must contain a worksheet named 'Salary' with data starting in row 2 " & _
"that consists of column A containing each name in the name/column layout worksheet " & _
"and column B containng their salary."
'
GoTo End_Sub
End If
'
'Make sure each name has a corresponding salary entry
'Initialize the scripting dictionary
Set oSD = CreateObject("Scripting.Dictionary")
oSD.CompareMode = vbTextCompare
'
'Inventory names on the main worksheet
For Each cel In ActiveSheet.Range("A1").CurrentRegion.Offset(1, 0)
cel.Value = Trim(cel.Value)
'
If cel.Value <> vbNullString Then
oSD.Item(cel.Value) = oSD.Item(cel.Value) + 1
End If
Next
'
'Remove names on the Salary worksheet
With Worksheets("Salary")
For Each cel In .Range("A2:A" & .Cells(Rows.Count, 1).End(xlUp).Row)
cel.Value = Trim(cel.Value)
'
If oSD.Exists(cel.Value) Then
oSD.Remove cel.Value
End If
Next
End With
'
'Any names not accounted for?
If oSD.Count <> 0 Then
TempArray = oSD.keys
'
For ArrayColumn = LBound(TempArray) To UBound(TempArray)
sMissingSalary = sMissingSalary & ", " & TempArray(ArrayColumn)
Next
'
sMissingSalary = Mid(sMissingSalary, 3)
'
MsgBox "The following names on the main worksheet do not have a corresponding entry on the 'Salary' worksheet." & _
vbLf & vbLf & sMissingSalary
Debug.Print "The following names on the main worksheet do not have a corresponding entry on the 'Salary' worksheet." & _
vbLf & vbLf & sMissingSalary
'
GoTo End_Sub
End If
'
Set oSD = CreateObject("Scripting.Dictionary") ' Erase contents of dictionary
Set oSD = Nothing ' Delete the dictionary
'
If TypeName(ActiveSheet) <> "Worksheet" Then
bShowError = True
End If
'
If bShowError Then
MsgBox "Ensure a Worksheet is active with a header row starting in A1" & "and names under each header entry.", , "Problems Found in Data"
GoTo End_Sub
End If
'
lLastColumn = Range("A1").CurrentRegion.Columns.Count
lLastUsedColumn = ActiveSheet.UsedRange.Columns.Count
ReDim aryNames(1 To 2, 1 To lLastColumn) '1 holds the in-use entry row
'
'How many combinations? (Order does not matter)
lLastIteration = 1
'
For ArrayColumn = 1 To lLastColumn
aryNames(1, ArrayColumn) = 2
aryNames(2, ArrayColumn) = Cells(Rows.Count, ArrayColumn).End(xlUp).Row
lLastIteration = lLastIteration * (aryNames(2, ArrayColumn) - 1)
Next
'
MaxNoDupeRowArrayRows = lLastIteration * LastIterationMultiplier
'
Erase aryNames
'
lFirstWriteColumn = lLastColumn + 2
lLastWriteColumn = (2 * lLastColumn) + 1
'
Select Case MsgBox("Process a " & lLastColumn & " column table with " & _
lLastIteration & " possible combinations?" & vbLf & vbLf & _
"WARNING: Columns right of the input range will be erased before continuing.", vbOKCancel + vbExclamation + _
vbDefaultButton2, "Process table?")
'
Case vbCancel
GoTo End_Sub
End Select
'
'-------------------------------------------------------------------------------------------------------------------------------
'
' 2) Clear all columns to the right of Column I on the "Worksheet" sheet. Copy headers from A1:I1 on the "Worksheet" sheet to K1:S1 on the "Worksheet" sheet.
' Add header "ComboID" to T1 on the "Worksheet" sheet. Create the combinations & if there are no duplicate names in the same combination row & no
' summed salaries > 60000, then write the combination row to NoDupeRowArray.
'
dteStart = Now()
StartTime = Now()
'
PassNumber = 1 ' Initialize PassNumber
MaxPasses = Int((lLastIteration - 1) / MaxCombinationRows) + 1 ' Determine number of passes that will be performed to process all of the combinations
Application.StatusBar = "Step 1 of 6 ... Calculating name combinations & saving combinations " & _
"with no duplicate names in same combination & salaries <= " & MaxSalaryAllowed & " ..." & _
" Pass # " & PassNumber & " of " & MaxPasses
DoEvents
'
'Clear all columns right of input range
If lLastUsedColumn > lLastColumn Then
Range(Cells(1, lLastColumn + 1), Cells(1, lLastUsedColumn)).EntireColumn.ClearContents
End If
'
' Save Worksheet data into 2D 1 based WorksheetNamesArray
Set WorksheetNameRange = wksData.Range("A2:" & Split(Cells(1, lLastColumn).Address, "$")(1) & _
wksData.Range("A1").CurrentRegion.Find("*", , xlFormulas, , xlByRows, xlPrevious).Row)
WorksheetNamesArray = WorksheetNameRange
'
Cells(1, lLastWriteColumn + 1).Value = "ComboID"
'
'Add Output Header
Range(Cells(1, 1), Cells(1, lLastColumn)).Copy Destination:=Cells(1, lFirstWriteColumn)
'
'-------------------------------------------------------------------------------------------------------
'
' Create SalarySheetShortenedArray to store just the data that we need from the 'Salay' sheet
'
With Worksheets("Salary") '''' SALARY
lLastSalaryRow = .Cells(.Rows.Count, 1).End(xlUp).Row '
End With
'
With CreateObject("scripting.dictionary")
.CompareMode = vbTextCompare '
'
For Each cel In WorksheetNameRange ' Loop through each cell in the WorksheetNameRange
If cel <> "" Then ' If the cell is not blank then ...
If Not .Exists(cel.Value) Then ' If the value has not already been saved then ...
.Add cel.Value, cel.Value ' Save the value
End If
End If
'
UniqueWorksheetNamesArray = Application.Transpose(Array(.keys)) ' Transpose results to 2D 1 based UniqueWorksheetNamesArray
Next ' Loop back
End With
'
Set WorksheetNameRange = Nothing
Set cel = Nothing
'
SalarySheetFullArray = names.Range("A2:" & Split(Cells(names.Cells.Find("*", , _
xlFormulas, , xlByColumns, xlPrevious).Column).Address, "$")(1) & lLastSalaryRow) ' Save all of the data from the 'Salary' aheet into 2D 1 based SalarySheetFullArray
'
ReDim SalarySheetShortenedArray(1 To UBound(SalarySheetFullArray, 1), _
1 To UBound(SalarySheetFullArray, 2)) ' Set 2D 1 based SalarySheetShortenedArray to the size of SalarySheetFullArray
'
CurrentRow = 0 ' Initialize CurrentRow
'
For UniqueArrayRow = 1 To UBound(UniqueWorksheetNamesArray, 1) ' Loop through the rows of UniqueWorksheetNamesArray
For ArrayRow = 1 To UBound(SalarySheetFullArray, 1) ' Loop through the rows of SalarySheetFullArray
If UniqueWorksheetNamesArray(UniqueArrayRow, 1) = SalarySheetFullArray(ArrayRow, 1) Then ' If name from UniqueWorksheetNamesArray is found in SalarySheetFullArray then ...
CurrentRow = CurrentRow + 1 ' Increment CurrentRow
'
For ArrayColumn = 1 To UBound(SalarySheetFullArray, 2) ' Loop through the columns of SalarySheetFullArray
SalarySheetShortenedArray(CurrentRow, ArrayColumn) = _
SalarySheetFullArray(ArrayRow, ArrayColumn) ' Save the values to SalarySheetShortenedArray
Next ' Loop back
End If
Next ' Loop back
Next ' Loop back
'
Erase SalarySheetFullArray
Erase UniqueWorksheetNamesArray
'
SalarySheetShortenedArray = ReDimPreserve(SalarySheetShortenedArray, CurrentRow, _
UBound(SalarySheetShortenedArray, 2)) ' Resize SalarySheetShortenedArray to correct the actual rows used in the array
'
' Load data from 'Worksheet', each column of data will be loaded into a separate array
ReDim WorksheetColumnArray(1 To lLastColumn) ' Set the # of arrays in 'jagged' array WorksheetColumnArray
'
For ArrayColumn = 1 To lLastColumn ' Loop through the columns of 'Worksheet'
lLastRow = Cells(Rows.Count, ArrayColumn).End(xlUp).Row ' Get LastRow of the column
'
ReDim TempArray(1 To lLastRow - 1, 1 To 1) ' Set the rows & columns of 2D 1 based TempArray
WorksheetColumnArray(ArrayColumn) = TempArray ' Copy the empty 2D 1 based TempArray to WorksheetColumnArray()
'
For ArrayRow = 1 To lLastRow - 1 ' Loop through the rows of data in the column
WorksheetColumnArray(ArrayColumn)(ArrayRow, 1) = WorksheetNamesArray(ArrayRow, ArrayColumn) ' Save the data to WorksheetColumnArray()
Next ' Loop back
Next ' Loop back
'
'-------------------------------------------------------------------------------------------------------
'
' Start creating name combinations
'
CurrentRow = 0 ' Reset CurrentRow
lIterationCount = 0 ' Reset lIterationCount
lWriteRow = 0 ' Reset lWriteRow
NoDupeRow2 = 0 ' Reset NoDupeRow2
'
ReDim NamesAndComboIdArray(1 To MaxNoDupeRowArrayRows, 1 To lLastColumn + 1) ' Set the # of rows/columns for NamesAndComboIdArray
ReDim NoDupeRowArray(1 To MaxNoDupeRowArrayRows, 1 To lLastColumn + 2) ' Set the # of rows/columns for NoDupeRowArray
ReDim TempArray(1 To MaxCombinationRows, 1 To lLastColumn + 2) ' Set up TempArray with rows = MaxCombinationRows & columns 3 more than data range
ReDim TempArray2(1 To MaxCombinationRows, 1 To lLastColumn + 2) ' Set up TempArray2 with rows = MaxCombinationRows & columns 3 more than data range
'
For ColumnA_Row = 1 To UBound(WorksheetColumnArray(1), 1) ' Loop through rows of WorksheetColumnArray(1) ... Column A
For ColumnB_Row = 1 To UBound(WorksheetColumnArray(2), 1) ' Loop through rows of WorksheetColumnArray(2) ... Column B
For ColumnC_Row = 1 To UBound(WorksheetColumnArray(3), 1) ' Loop through rows of WorksheetColumnArray(3) ... Column C
For ColumnD_Row = 1 To UBound(WorksheetColumnArray(4), 1) ' Loop through rows of WorksheetColumnArray(4) ... Column D
For ColumnE_Row = 1 To UBound(WorksheetColumnArray(5), 1) ' Loop through rows of WorksheetColumnArray(5) ... Column E
For ColumnF_Row = 1 To UBound(WorksheetColumnArray(6), 1) ' Loop through rows of WorksheetColumnArray(6) ... Column F
For ColumnG_Row = 1 To UBound(WorksheetColumnArray(7), 1) ' Loop through rows of WorksheetColumnArray(7) ... Column G
For ColumnH_Row = 1 To UBound(WorksheetColumnArray(8), 1) ' Loop through rows of WorksheetColumnArray(8) ... Column H
For ColumnI_Row = 1 To UBound(WorksheetColumnArray(9), 1) ' Loop through rows of WorksheetColumnArray(9) ... Column I
lIterationCount = lIterationCount + 1 ' Increment lIterationCount
'
' Point to the next blank row in the NoDupeRowArray
lWriteRow = lWriteRow + 1 ' Increment lWriteRow for TempArray
'
' Save the combination & ComboID to TempArray
TempArray(lWriteRow, 1) = WorksheetColumnArray(1)(ColumnA_Row, 1) ' Save name from column A to TempArray
TempArray(lWriteRow, 2) = WorksheetColumnArray(2)(ColumnB_Row, 1) ' Save name from column B to TempArray
TempArray(lWriteRow, 3) = WorksheetColumnArray(3)(ColumnC_Row, 1) ' Save name from column C to TempArray
TempArray(lWriteRow, 4) = WorksheetColumnArray(4)(ColumnD_Row, 1) ' Save name from column D to TempArray
TempArray(lWriteRow, 5) = WorksheetColumnArray(5)(ColumnE_Row, 1) ' Save name from column E to TempArray
TempArray(lWriteRow, 6) = WorksheetColumnArray(6)(ColumnF_Row, 1) ' Save name from column F to TempArray
TempArray(lWriteRow, 7) = WorksheetColumnArray(7)(ColumnG_Row, 1) ' Save name from column G to TempArray
TempArray(lWriteRow, 8) = WorksheetColumnArray(8)(ColumnH_Row, 1) ' Save name from column H to TempArray
TempArray(lWriteRow, 9) = WorksheetColumnArray(9)(ColumnI_Row, 1) ' Save name from column I to TempArray
'
TempArray(lWriteRow, lLastColumn + 1) = lIterationCount ' Save lIterationCount to TempArray
'
'-----------------------------------------------------------------------------------------------------------
'
' If we have reached the MaxCombinationRows to generate at 1 time then
' Write the TempArray to the sheet, apply duplicate name check formulas to each row & save resulting data range back to TempArray
If lWriteRow = MaxCombinationRows Then ' If we have written MaxCombinationRows to TempArray then ...
ActiveSheet.Cells(2, lFirstWriteColumn).Resize(UBound(TempArray, _
1), UBound(TempArray, 2)) = TempArray ' Write the TempArray to the sheet
'
lLastRow = Cells(Rows.Count, lFirstWriteColumn).End(xlUp).Row ' Get lLastRow
lLastUsedColumn = Rows(1).Find("*", , xlFormulas, , _
xlByColumns, xlPrevious).Column ' Get LastUsedColumn in row 1
'
Set rngFormulaRange = Range(Cells(2, lLastUsedColumn + 1), _
Cells(lLastRow, lLastUsedColumn + 1)) ' Set Range to place the duplicate check formulas in
'
With rngFormulaRange
.Formula = "=MODE.MULT(MATCH($" & Split(Cells(1, _
lFirstWriteColumn).Address, "$")(1) & "2:$" & _
Split(Cells(1, lLastWriteColumn).Address, "$")(1) & _
"2,$" & Split(Cells(1, lFirstWriteColumn).Address, _
"$")(1) & "2:$" & Split(Cells(1, _
lLastWriteColumn).Address, "$")(1) & "2,0))" ' Formula to check for duplicates in same row
Application.Calculate '
.Value = .Value '
End With
'
TempArray = ActiveSheet.Cells(2, lFirstWriteColumn).Resize( _
UBound(TempArray, 1), UBound(TempArray, 2)) ' Load data with formula results back into TempArray
'
ActiveSheet.Cells(2, lFirstWriteColumn).Resize(UBound(TempArray, 1), _
UBound(TempArray, 2)).ClearContents ' Clear the data range
'
'-----------------------------------------------------------------------------------------------------------
'
' Loop through rows of TempArray & copy the rows that have no duplicate names to TempArray2 & NamesAndComboIdArray
NoDupeRow = 0 ' Reset NoDupeRow
'
For ArrayRow = 1 To UBound(TempArray, 1) ' Loop through rows of TempArray
If Application.WorksheetFunction.IsNA(TempArray(ArrayRow, _
UBound(TempArray, 2))) Then ' If formula resulted in '#N/A' then ...
NoDupeRow = NoDupeRow + 1 ' Increment NoDupeRow, this is the
' ' row of the TempArray2
CurrentRow = CurrentRow + 1 ' Increment CurrentRow
'
For ArrayColumn = 1 To UBound(TempArray, 2) - 1 ' Loop through columns of
' ' TempArray, except last column
TempArray2(NoDupeRow, ArrayColumn) = _
TempArray(ArrayRow, ArrayColumn) ' Save names/ComboID to TempArray2
'
NamesAndComboIdArray(CurrentRow, ArrayColumn) = _
TempArray(ArrayRow, ArrayColumn) ' Save names/ComboID to NamesAndComboIdArray
Next ' Loop back
End If
Next ' Loop back
'
TempArray2 = ReDimPreserve(TempArray2, NoDupeRow, _
UBound(TempArray2, 2)) ' Resize TempArray2 to correct the actual rows used in the array
'
'-----------------------------------------------------------------------------------------------------------
'
' Load Salary ammounts for each player into TempArray2
For ArrayRow = 1 To UBound(TempArray2, 1) ' Loop through rows of TempArray2
For ArrayColumn = 1 To UBound(TempArray2, 2) ' Loop through columns of TempArray2
For SalarySheetShortenedArrayRow = 1 To _
UBound(SalarySheetShortenedArray, 1) ' Loop through rows of SalarySheetShortenedArray
If SalarySheetShortenedArray(SalarySheetShortenedArrayRow, _
1) = TempArray2(ArrayRow, ArrayColumn) Then ' If we find a match then ...
TempArray2(ArrayRow, ArrayColumn) = _
SalarySheetShortenedArray(SalarySheetShortenedArrayRow, 2) ' Save the salary amount
Exit For ' Exit this For loop
End If
Next '
Next ' Loop back
Next ' Loop back
'
'-----------------------------------------------------------------------------------------------------------
'
' Write TempArray2 to sheet, add up all of the salaries for each row & save results back to TempArray
'
ActiveSheet.Cells(2, lFirstWriteColumn).Resize(UBound(TempArray2, _
1), UBound(TempArray2, 2)) = TempArray2 ' Write the TempArray2 to the sheet
'
ReDim TempArray2(1 To MaxCombinationRows, 1 To lLastColumn + 2) ' Clear results from TempArray2
'
lLastRow = Cells(Rows.Count, lFirstWriteColumn).End(xlUp).Row ' Get lLastRow
'
Columns(lLastUsedColumn).Insert ' Insert column for the 'Salary'
'
Cells(1, lLastUsedColumn).Value = ChrW(931) & " Salary" ' 20 ... T
'
With Range(Cells(2, lLastUsedColumn), Cells(lLastRow, lLastUsedColumn))
.FormulaR1C1 = "=SUM(RC" & lFirstWriteColumn & ":RC" & _
lLastWriteColumn & ")" ' Sum formula for the column
Application.Calculate '
.Value = .Value '
End With
'
TempArray = ActiveSheet.Cells(2, lFirstWriteColumn).Resize( _
lLastRow - 1, UBound(TempArray, 2)) ' Load data with formula results back into TempArray
'
'-----------------------------------------------------------------------------------------------------------
'
' Loop through rows of TempArray & copy the rows that meet salary stipulation to NoDupeRowArray
For ArrayRow = 1 To UBound(TempArray, 1) ' Loop through rows of TempArray
If TempArray(ArrayRow, UBound(TempArray, 2) - 1) _
<= MaxSalaryAllowed Then ' If we have an allowable salary then ...
NoDupeRow2 = NoDupeRow2 + 1 ' Increment NoDupeRow2, this is the
' ' row of the NoDupeRowArray
For ArrayColumn = 1 To UBound(TempArray, 2) ' Loop through columns of TempArray
NoDupeRowArray(NoDupeRow2, ArrayColumn) = _
TempArray(ArrayRow, ArrayColumn) ' Save values to NoDupeRowArray
Next ' Loop back
End If
Next ' Loop back
'
'-----------------------------------------------------------------------------------------------------------
'
' Clean up & update StatusBar
lWriteRow = 0 ' Reset lWriteRow for TempArray
'
ActiveSheet.Cells(2, lFirstWriteColumn).Resize(UBound(TempArray, 1), _
UBound(TempArray, 2)).ClearContents ' Clear the data range
'
Columns(lLastUsedColumn).EntireColumn.Delete ' Delete the 'Salary' column
'
ReDim TempArray(1 To MaxCombinationRows, 1 To lLastColumn + 2) ' Clear results from TempArray
'
PassNumber = PassNumber + 1 ' Increment PassNumber
'
Application.StatusBar = "Step 1 of 6 ... Calculating name " & _
"combinations & saving combinations with no duplicate " & _
"names in same combination & salaries <= " & _
MaxSalaryAllowed & " ... Pass # " & PassNumber & " of " & _
MaxPasses & " ... Useable combinations found thus far " & _
"= " & NoDupeRow2 ' Update the user via StatusBar of the status
DoEvents
'-----------------------------------------------------------------------------------------------------------
End If
Next ' Loop back
Next ' Loop back
Next ' Loop back
Next ' Loop back
Next ' Loop back
Next ' Loop back
Next ' Loop back
Next ' Loop back
Next ' Loop back
'
Erase WorksheetColumnArray
'
'-----------------------------------------------------------------------------------------------------------
'
' If more combinations exist then Write the TempArray to the sheet, apply duplicate name check formulas to each row & save resulting data range back to TempArray
If TempArray(1, 1) <> vbNullString Then ' If there are more cominations needing to be checked then ...
ActiveSheet.Cells(2, lFirstWriteColumn).Resize(UBound(TempArray, 1), UBound(TempArray, 2)) = TempArray ' Write the TempArray to the sheet
'
lLastRow = Cells(Rows.Count, lFirstWriteColumn).End(xlUp).Row ' Get lLastRow
lLastUsedColumn = Rows(1).Find("*", , xlFormulas, , xlByColumns, xlPrevious).Column ' Get LastUsedColumn in row 1
'
Set rngFormulaRange = Range(Cells(2, lLastUsedColumn + 1), Cells(lLastRow, lLastUsedColumn + 1)) ' Set Range to place the duplicate names check formulas in
'
With rngFormulaRange
.Formula = "=MODE.MULT(MATCH($" & Split(Cells(1, lFirstWriteColumn).Address, "$")(1) & "2:$" & _
Split(Cells(1, lLastWriteColumn).Address, "$")(1) & "2,$" & _
Split(Cells(1, lFirstWriteColumn).Address, "$")(1) & "2:$" & _
Split(Cells(1, lLastWriteColumn).Address, "$")(1) & "2,0))" ' Formula to check for duplicates in same row
Application.Calculate '
.Value = .Value '
End With
'
TempArray = ActiveSheet.Cells(2, lFirstWriteColumn).Resize(UBound(TempArray, 1), UBound(TempArray, 2)) ' Load data with formula results back into TempArray
'
ActiveSheet.Cells(2, lFirstWriteColumn).Resize(UBound(TempArray, 1), _
UBound(TempArray, 2)).ClearContents ' Clear the data range
'
'-----------------------------------------------------------------------------------------------------------
'
' Loop through rows of TempArray & copy the rows that have no duplicate names to TempArray2 & NamesAndComboIdArray
NoDupeRow = 0 ' Reset NoDupeRow
'
For ArrayRow = 1 To UBound(TempArray, 1) ' Loop through rows of TempArray
If Application.WorksheetFunction.IsNA(TempArray(ArrayRow, UBound(TempArray, 2))) Then ' If formula resulted in '#N/A' then ...
NoDupeRow = NoDupeRow + 1 ' Increment NoDupeRow, this is the row of the TempArray2
CurrentRow = CurrentRow + 1 ' Increment CurrentRow
'
For ArrayColumn = 1 To UBound(TempArray, 2) - 1 ' Loop through columns of TempArray, except last column
TempArray2(NoDupeRow, ArrayColumn) = TempArray(ArrayRow, ArrayColumn) ' Save names/ComboID to TempArray2
'
NamesAndComboIdArray(CurrentRow, ArrayColumn) = TempArray(ArrayRow, ArrayColumn) ' Save names/ComboID to NamesAndComboIdArray
Next ' Loop back
End If
Next ' Loop back
'
TempArray2 = ReDimPreserve(TempArray2, NoDupeRow, UBound(TempArray2, 2)) ' Resize TempArray2 to correct the actual rows used in the array
'
'-----------------------------------------------------------------------------------------------------------
'
' Load Salary ammounts for each player into TempArray2
For ArrayRow = 1 To UBound(TempArray2, 1) ' Loop through rows of TempArray2
For ArrayColumn = 1 To UBound(TempArray2, 2) ' Loop through columns of TempArray2
For SalarySheetShortenedArrayRow = 1 To UBound(SalarySheetShortenedArray, 1) ' Loop through rows of SalarySheetShortenedArray
If SalarySheetShortenedArray(SalarySheetShortenedArrayRow, 1) = _
TempArray2(ArrayRow, ArrayColumn) Then ' If we find a match then ...
TempArray2(ArrayRow, ArrayColumn) = _
SalarySheetShortenedArray(SalarySheetShortenedArrayRow, 2) ' Save the salary amount
Exit For ' Exit this For loop
End If
Next ' Loop back
Next ' Loop back
Next ' Loop back
'
'-----------------------------------------------------------------------------------------------------------
'
' Write TempArray2 to sheet, add up all of the salaries for each row & save results back to TempArray
'
ActiveSheet.Cells(2, lFirstWriteColumn).Resize(UBound(TempArray2, 1), UBound(TempArray2, 2)) = TempArray2 ' Write the TempArray2 to the sheet
'
Erase TempArray2 '
'
lLastRow = Cells(Rows.Count, lFirstWriteColumn).End(xlUp).Row ' Get lLastRow
'
Columns(lLastUsedColumn).Insert ' Insert column 20 ... U for the 'Salary'
'
Cells(1, lLastUsedColumn).Value = ChrW(931) & " Salary" ' 20 ... T
'
With Range(Cells(2, lLastUsedColumn), Cells(lLastRow, lLastUsedColumn))
.FormulaR1C1 = "=SUM(RC" & lFirstWriteColumn & ":RC" & lLastWriteColumn & ")" ' Formula to Sum the salaries
Application.Calculate '
.Value = .Value '
End With
'
TempArray = ActiveSheet.Cells(2, lFirstWriteColumn).Resize(lLastRow - 1, UBound(TempArray, 2)) ' Load data with formula results back into TempArray
'
ActiveSheet.Cells(2, lFirstWriteColumn).Resize(UBound(TempArray, 1), UBound(TempArray, 2)).ClearContents ' Clear the data range
'
Columns(lLastUsedColumn).EntireColumn.Delete ' Delete the 'Salary' column
'
'-----------------------------------------------------------------------------------------------------------
'
' Loop through rows of TempArray & copy the rows that meet the MaxSalaryAllowed stipulation to NoDupeRowArray
For ArrayRow = 1 To UBound(TempArray, 1) ' Loop through rows of TempArray
If TempArray(ArrayRow, UBound(TempArray, 2) - 1) <= MaxSalaryAllowed Then ' If we have an allowable salary then ...
NoDupeRow2 = NoDupeRow2 + 1 ' Increment NoDupeRow2, this is the row of the NoDupeRowArray
'
For ArrayColumn = 1 To UBound(TempArray, 2) ' Loop through columns of TempArray, except last column
NoDupeRowArray(NoDupeRow2, ArrayColumn) = TempArray(ArrayRow, ArrayColumn) ' Save values to NoDupeRowArray
Next ' Loop back
End If
Next ' Loop back
End If
'
NoDupeRowArray = ReDimPreserve(NoDupeRowArray, NoDupeRow2, UBound(NoDupeRowArray, 2)) ' Resize NoDupeRowArray to correct the actual rows used in the array
'
'-----------------------------------------------------------------------------------------------------------
'
' Clean up & update 'Immediate' window (CTRL+G) in VBE
Erase TempArray '
'
Debug.Print "Create all combinations & remove rows with duplicate name entries in the same row &" _
; " & remove all combinations with salaries > " & MaxSalaryAllowed & " completed in:" & _
Space(4) & Format(Now() - StartTime, "hh:mm:ss") & ", leaving " & UBound(NoDupeRowArray, 1) & _
" combination rows." ' Display elapsed time for this process to the 'Immediate' window (CTRL+G) in VBE
'
' At this point, NoDupeRowArray(1 thru 9) = Salaries for individual names, 10 = summed salary, 11 = ComboID
'
'-------------------------------------------------------------------------------------------------------------------------------
'
' 3) Restore names in original order to the combinations remaining
'
StartTime = Now()
'
Application.StatusBar = "Step 2 of 6 ... Restoring original name order in the current rows ..."
DoEvents
'
CurrentRow = 1 ' Initialize CurrentRow
'
For ArrayRow = LBound(NamesAndComboIdArray, 1) To UBound(NamesAndComboIdArray, 1) ' Loop through rows of NamesAndComboIdArray
If NamesAndComboIdArray(ArrayRow, UBound(NamesAndComboIdArray, 2)) = _
NoDupeRowArray(CurrentRow, UBound(NoDupeRowArray, 2)) Then ' If we found matching ComboID's then ...
'
For ArrayColumn = LBound(NamesAndComboIdArray, 2) To UBound(NamesAndComboIdArray, 2) - 1 ' Loop through the columns of NamesAndComboIdArray except for the last column
NoDupeRowArray(CurrentRow, ArrayColumn) = NamesAndComboIdArray(ArrayRow, ArrayColumn) ' Save the name from the row/column to NoDupeRowArray
Next ' Loop back
'
CurrentRow = CurrentRow + 1 ' Increment CurrentRow
'
If CurrentRow > UBound(NoDupeRowArray, 1) Then Exit For ' Exit For loop if we have processed all rows in NoDupeRowArray
End If
Next ' Loop back
'
Erase NamesAndComboIdArray
'
Debug.Print "Restore Original order of names in the remaining combinations completed in:" & _
Space(74) & Format(Now() - StartTime, "hh:mm:ss") ' Display elapsed time for this process to the 'Immediate' window (CTRL+G) in VBE
'
' At this point, NoDupeRowArray(1 thru 9) = names in original order, 10 = summed salary, 11 = ComboID
'
'-------------------------------------------------------------------------------------------------------------------------------
'
' 4) Create a 'jagged array', which is just an array of arrays, of the remaining combinations. This us what allows us to handle
' larger amounts of combinations. Instead of trying to write them all to the sheet for sorting, we will use the jagged array
' to write amounts of combinations to the sheet that doesn't exceed the maximum amount of rows that Excel allows. We then
' sort those rows & save the result back to the jagged array subArray, clear the sheet, write the next subArray to the sheet, sort the data,
' save it back to the jagged array, etc.
'
StartTime = Now()
'
Application.StatusBar = "Step 3 of 6 ... Sorting remaining combination rows alphabetically by row ..."
DoEvents
'
SubArrays = Int((UBound(NoDupeRowArray, 1) - 1) / MaxRowsPerSubArray) + 1 ' Determine number of SubArrays needed
'
ReDim JaggedArray(1 To SubArrays) ' Set the # of SubArrays in JaggedArray
'
CurrentRow = 0 ' Reset CurrentRow
'
' Create array(s) of combinations
For SubArrayNumber = 1 To SubArrays ' Loop through SubArrays
ReDim TempArray(1 To MaxRowsPerSubArray, 1 To UBound(NoDupeRowArray, 2)) ' Reset the TempArray
'
For SubArrayRow = 1 To MaxRowsPerSubArray ' Loop through rows of TempArray
CurrentRow = CurrentRow + 1 ' Increment CurrentRow, this is the row of the NoDupeRowArray
'
If CurrentRow > UBound(NoDupeRowArray, 1) Then Exit For ' If all of the rows have been processed then exit this For loop
'
For ArrayColumn = 1 To UBound(NoDupeRowArray, 2) ' Loop through columns of NoDupeRowArray
TempArray(SubArrayRow, ArrayColumn) = NoDupeRowArray(CurrentRow, ArrayColumn) ' Save column value into TempArray
Next ' Loop back
Next ' Loop back
'
JaggedArray(SubArrayNumber) = TempArray ' Save the TempArray to the JaggedArray
'
Erase TempArray
Next ' Loop back
'
' At this point, all of the remaining combinations have been loaded into the JaggedArray subArrays
'
' Write each subArray to the sheet, sort each row & save results back into the subArray
For SubArrayNumber = 1 To SubArrays ' Loop through SubArrays
ActiveSheet.Cells(2, lFirstWriteColumn).Resize(UBound(JaggedArray(SubArrayNumber), 1), _
UBound(JaggedArray(SubArrayNumber), 2)) = JaggedArray(SubArrayNumber) ' Write the subArray to the sheet for sorting
'
ActiveSheet.Sort.SortFields.Clear '
'
' Sort each row
lLastRow = Cells(Rows.Count, lFirstWriteColumn).End(xlUp).Row ' Get lLastRow
'
Set rngSortRange = Range(Cells(2, lFirstWriteColumn), Cells(lLastRow, lLastWriteColumn)) ' Set the Range to be sorted
'
For Each cel In rngSortRange.Rows ' Loop through each row of the range to be sorted
cel.Sort Key1:=cel.Cells(1, 1), Order1:=xlAscending, Header:=xlNo, Orientation:=xlSortRows ' Sort each row alphabetically
Next ' Loop back
'
Set rngSortRange = Nothing
Set cel = Nothing
'
' Load the sorted data back into the subArray
JaggedArray(SubArrayNumber) = ActiveSheet.Cells(2, lFirstWriteColumn).Resize(UBound( _
JaggedArray(SubArrayNumber), 1), UBound(JaggedArray(SubArrayNumber), 2)) '
'
ActiveSheet.Cells(2, lFirstWriteColumn).Resize(UBound(JaggedArray(SubArrayNumber), 1), _
UBound(JaggedArray(SubArrayNumber), 2)).ClearContents ' Clear the sort range
Next ' Loop back
'
Debug.Print "Sort remaining combination rows alphabetically by row completed " & _
"in:" & Space(82) & Format(Now() - StartTime, "hh:mm:ss") ' Display elapsed time for this process to the 'Immediate' window (CTRL+G) in VBE
'
' At this point, the subArrays contain the sorted names in columns 1 thru 9, 10 = summed salary, 11 = ComboID
'
'-------------------------------------------------------------------------------------------------------------------------------
'
' 5) Copy unique sorted rows from the subArrays to NoDupeSortedRowsArray
'
StartTime = Now()
'
Application.StatusBar = "Step 4 of 6 ... Removing duplicate sorted rows ..."
DoEvents
'
ReDim NoDupeSortedRowsArray(1 To UBound(NoDupeRowArray, 1), 1 To UBound(NoDupeRowArray, 2)) '
'
' Join all of the sorted subArray unique rows back into 1 large array
'
'Initialize the scripting dictionary
Set oSD = CreateObject("Scripting.Dictionary")
oSD.CompareMode = vbTextCompare
'
CurrentRow = 0 ' Reset CurrentRow
'
For SubArrayNumber = 1 To SubArrays ' Loop through the SubArrays
For SubArrayRow = 1 To UBound(JaggedArray(SubArrayNumber), 1) ' Loop through rows of each subArray in the JaggedArray
oSD_KeyString = "" ' Erase 'oSD_KeyString'
Delimiter = "" ' Erase 'Delimiter' of NoDupeSortedRowsArray
'
For SubArrayColumn = 1 To UBound(JaggedArray(SubArrayNumber), 2) - 2 ' Loop through columns, except last 2 columns of
' ' JaggedArray(SubArrayNumber)
oSD_KeyString = oSD_KeyString & Delimiter & _
JaggedArray(SubArrayNumber)(SubArrayRow, SubArrayColumn) ' Save data from JaggedArray(SubArrayNumber) row, separated
' ' by Delimiter, into oSD_KeyString
Delimiter = Chr(2)
Next ' Loop back
'
If Not oSD.Exists(oSD_KeyString) Then ' If this is a unique sorted name row then ...
oSD.Add oSD_KeyString, "" ' Add it to the dictionary
'
CurrentRow = CurrentRow + 1 ' Increment CurrentRow
'
For ArrayColumn = 1 To UBound(JaggedArray(SubArrayNumber), 2) ' Loop through columns of JaggedArray(SubArrayNumber)
NoDupeSortedRowsArray(CurrentRow, ArrayColumn) = _
JaggedArray(SubArrayNumber)(SubArrayRow, ArrayColumn) ' Save values to NoDupeRowArray
Next ' Loop back
End If
Next ' Loop back
'
Erase JaggedArray(SubArrayNumber)
Next ' Loop back
'
Erase JaggedArray
'
Set oSD = CreateObject("Scripting.Dictionary") ' Erase contents of dictionary
Set oSD = Nothing ' Delete the dictionary
'
NoDupeSortedRowsArray = ReDimPreserve(NoDupeSortedRowsArray, _
CurrentRow, UBound(NoDupeSortedRowsArray, 2)) ' Resize NoDupeSortedRowsArray to correct the actual rows used in the array
'
Debug.Print "Removal of duplicate sorted rows completed in:" & Space(103) & _
Format(Now() - StartTime, "hh:mm:ss") & ", leaving " & UBound(NoDupeSortedRowsArray, 1) - 1 & _
" combination rows." ' Display elapsed time for this process to the 'Immediate' window (CTRL+G) in VBE
'
' At this point, the unique sorted rows have been written to NoDupeSortedRowsArray &
' NoDupeSortedRowsArray(1 thru 9) = names in sorted order, 10 = summed salary, 11 = ComboID
'
'-------------------------------------------------------------------------------------------------------
'
' 6) Now we need to match the ComboID in NoDupeSortedRowsArray to the ComboID in NoDupeRowArray so we can
' put the names for that row back to the original order
'
StartTime = Now()
'
Application.StatusBar = "Step 5 of 6 ... Restoring original name order in the sorted rows ..."
DoEvents
'
CurrentRow = 1 ' Initialize CurrentRow
'
For ArrayRow = LBound(NoDupeRowArray, 1) To UBound(NoDupeRowArray, 1) ' Loop through rows of NoDupeRowArray
If CurrentRow > UBound(NoDupeSortedRowsArray, 1) Then Exit For ' If we have processed all rows then exit this For loop
'
If NoDupeSortedRowsArray(CurrentRow, UBound(NoDupeSortedRowsArray, 2)) = _
NoDupeRowArray(ArrayRow, UBound(NoDupeRowArray, 2)) Then ' If we found matching ComboID's then ...
'
For ArrayColumn = LBound(NoDupeRowArray, 2) To UBound(NoDupeRowArray, 2) - 2 ' Loop through the columns of NoDupeRowArray except for the last 2 columns
NoDupeSortedRowsArray(CurrentRow, ArrayColumn) = NoDupeRowArray(ArrayRow, ArrayColumn) ' Save the name from the row/column to NoDupeSortedRowsArray
Next ' Loop back
'
CurrentRow = CurrentRow + 1 ' Increment CurrentRow
End If
Next ' Loop back
'
Erase NoDupeRowArray '
'
Debug.Print "Restore Original order of names in the remaining combinations completed in:" & _
Space(74) & Format(Now() - StartTime, "hh:mm:ss") ' Display elapsed time for this process to the 'Immediate' window (CTRL+G) in VBE
'
' At this point, NoDupeSortedRowsArray(1 thru 9) = names in original order, 10 = summed salary, 11 = ComboID
'
'
' At this point, all criteria for deletion of combination rows have been completed
'
'-------------------------------------------------------------------------------------------------------
'
' 7) A projection column is added to column AW. The projections from columns AD:AL are
' calculated(summed) and entered into column AW. A "Stack" column is added to column AX and the most used team in the combinations are calculated using the
' MODE function. A "Stack POS" column is added to column AY. The players position - who consisted of the most used team are added to column AY by pulling the
' column headers associated to the corresponding player using the TEXTJOIN function. A "" Stack2" column is added to the AZ column and a "Stack2 POS" column
' is added to the BA column - Both using the similar method as first stack column.
'
StartTime = Now()
'
Application.StatusBar = "Step 6 of 6 ...Wrapping up ..."
DoEvents
'
' Add Sum Column
Columns(lLastUsedColumn).Insert ' Insert column for the 'Salary'
'
Cells(1, lLastUsedColumn).Value = ChrW(931) & " Salary" ' 20 ... T
'
If UBound(NoDupeSortedRowsArray, 1) >= Rows.Count Then ' If the remaining amount of combinations> 1048576 then ...
ExcessCombinations = UBound(NoDupeSortedRowsArray, 1) - Rows.Count ' Calculate the remaining combinations that will not be printed
'
NoDupeSortedRowsArray = ReDimPreserve(NoDupeSortedRowsArray, Rows.Count - 1, _
UBound(NoDupeSortedRowsArray, 2)) ' Limit the displayed rows to the sheet allowable range, discard the rest of the combos
End If
'
Cells(2, lFirstWriteColumn).Resize(UBound(NoDupeSortedRowsArray, 1), _
UBound(NoDupeSortedRowsArray, 2)) = NoDupeSortedRowsArray ' Display NoDupeSortedRowsArray to 'Worksheet'
'
Erase NoDupeSortedRowsArray
'
' We need to swap the last 2 columns (Salary & ComboID)
Columns(lLastUsedColumn).Insert ' Insert a blank column
Columns(lLastUsedColumn + 2).Cut Cells(1, lLastUsedColumn) ' Cut/paste the last column into the inserted column
'
lLastRow = Cells(Rows.Count, lFirstWriteColumn).End(xlUp).Row '
'
lFirstHSortColumn = Rows(1).Find("*", , xlFormulas, , xlByColumns, xlPrevious).Column + 1 '
'
If lLastRow > 1 Then '
Range(Cells(1, lFirstWriteColumn), Cells(lLastRow, lLastWriteColumn)).Copy _
Destination:=Cells(1, lFirstHSortColumn) ' Rows for PROJECTION
'
lLastHSortColumn = Cells(1, Columns.Count).End(xlToLeft).Column ' 30 ... AD
'
Range(Cells(1, lFirstWriteColumn), Cells(lLastRow, lLastWriteColumn)).Copy _
Destination:=Cells(1, lLastHSortColumn + 1) ' Rows for TEAM
'
Application.CutCopyMode = False ' Clear the clipboard
'
lFirstHTeamCol = lLastHSortColumn + 1 ' 31 ... AE
lLastHTeamCol = Cells(1, Columns.Count).End(xlToLeft).Column ' 39 ... AM
'
'''''''''''''''''''''''''''''''''''''PROJECTION
'
TempArray = Range(Cells(2, lFirstHSortColumn), Cells(lLastRow, lLastHSortColumn)) '
'
' Load Projection ammounts for each player into TempArray
For ArrayRow = 1 To UBound(TempArray, 1) ' Loop through rows of TempArray
For ArrayColumn = 1 To UBound(TempArray, 2) ' Loop through columns of TempArray
For SalarySheetShortenedArrayRow = 1 To UBound(SalarySheetShortenedArray, 1) ' Loop through rows of SalarySheetShortenedArray
If SalarySheetShortenedArray(SalarySheetShortenedArrayRow, 1) = _
TempArray(ArrayRow, ArrayColumn) Then ' If we find a match then ...
TempArray(ArrayRow, ArrayColumn) = _
SalarySheetShortenedArray(SalarySheetShortenedArrayRow, 3) ' Save the projection amount
Exit For ' Exit this For loop
End If
Next ' Loop back
Next ' Loop back
Next ' Loop back
'
Range(Cells(2, lFirstHSortColumn), Cells(lLastRow, lLastHSortColumn)) = TempArray ' Write TempArray back to the sheet
'
Erase TempArray
'
'''''''''''''''''''''''''''''''''''''TEAM
'
TempArray2 = Range(Cells(2, lFirstHTeamCol), Cells(lLastRow, lLastHTeamCol)) '
'
' Load Team for each player into TempArray2
For ArrayRow = 1 To UBound(TempArray2, 1) ' Loop through rows of TempArray2
For ArrayColumn = 1 To UBound(TempArray2, 2) ' Loop through columns of TempArray2
For SalarySheetShortenedArrayRow = 1 To UBound(SalarySheetShortenedArray, 1) ' Loop through rows of SalarySheetShortenedArray
If SalarySheetShortenedArray(SalarySheetShortenedArrayRow, 1) = _
TempArray2(ArrayRow, ArrayColumn) Then ' If we find a match then ...
TempArray2(ArrayRow, ArrayColumn) = _
SalarySheetShortenedArray(SalarySheetShortenedArrayRow, 4) ' Save the Team
Exit For ' Exit this For loop
End If
Next ' Loop back
Next ' Loop back
Next ' Loop back
'
Range(Cells(2, lFirstHTeamCol), Cells(lLastRow, lLastHTeamCol)) = TempArray2 ' Write TempArray2 back to the sheet
'
Erase TempArray2
'
' Add Projection Column
Cells(1, lLastHTeamCol + 1).Value = ChrW(931) & " Projection" ' 40 ... AN
' Add Team Stack Column
Cells(1, lLastHTeamCol + 2).Value = ChrW(931) & " Stack" ' 41 ... AO
' Add Team Stack Pos
Cells(1, lLastHTeamCol + 3).Value = ChrW(931) & " Stack POS" ' 42 ... AP
' Add 2nd Team Stack Column
Cells(1, lLastHTeamCol + 4).Value = ChrW(931) & " Stack2" ' 43 ... AQ
' Add 2nd Team Stack Pos
Cells(1, lLastHTeamCol + 5).Value = ChrW(931) & " Stack2 POS" ' 44 ... AR
' Filter 0-1
Cells(1, lLastHTeamCol + 6).Value = ChrW(931) & " Filter" ' 45 ... AS
' Player 1 Filter
Cells(1, lLastHTeamCol + 7).Value = ChrW(931) & " Player1" ' 46 ... AT
' Player 2 Filter
Cells(1, lLastHTeamCol + 8).Value = ChrW(931) & " Player2" ' 47 ... AU
'
With Range(Cells(2, lLastHTeamCol + 1), Cells(lLastRow, lLastHTeamCol + 1))
.FormulaR1C1 = "=SUM(RC" & lFirstHSortColumn & ":RC" & lLastHSortColumn & ")" ' Projection formula
Application.Calculate '
.Value = .Value '
End With
'
With Range(Cells(2, lLastHTeamCol + 2), Cells(lLastRow, lLastHTeamCol + 2))
.FormulaR1C1 = "=INDEX(RC" & lFirstHTeamCol & ":RC" & lLastHTeamCol & ",MODE(MATCH(RC" & _
lFirstHTeamCol & ":RC" & lLastHTeamCol & ",RC" & lFirstHTeamCol & ":RC" & _
lLastHTeamCol & ",0)))" ' Stack formula
Application.Calculate '
.Value = .Value '
End With
'
With Range(Cells(2, lLastHTeamCol + 3), Cells(lLastRow, lLastHTeamCol + 3))
.Formula2R1C1 = "=TEXTJOIN("","",1,IF(RC[-11]:RC[-3]=RC[-1],R1C[-11]:R1C[-3],""""))" ' Stack POS
Application.Calculate '
.Value = .Value '
End With
'
With Range(Cells(2, lLastHTeamCol + 4), Cells(lLastRow, lLastHTeamCol + 4))
.Formula2R1C1 = "=IFERROR(INDEX(RC[-12]:RC[-4],MODE(IF((RC[-12]:RC[-4]<>"""")*" & _
"(RC[-12]:RC[-4]<>INDEX(RC[-12]:RC[-4],MODE(IF(RC[-12]:RC[-4]<>"""",MATCH(" & _
"RC[-12]:RC[-4],RC[-12]:RC[-4],0))))),MATCH(RC[-12]:RC[-4],RC[-12]:RC[-4],0)))),"""")" ' Stack2 formula
Application.Calculate '
.Value = .Value '
End With
'
With Range(Cells(2, lLastHTeamCol + 5), Cells(lLastRow, lLastHTeamCol + 5))
.Formula2R1C1 = "=TEXTJOIN("","",1,IF(RC[-13]:RC[-5]=RC[-1],R1C[-13]:R1C[-5],""""))" '
Application.Calculate '
.Value = .Value '
End With
'
'-------------------------------------------------------------------------------------------------------------------------------
'
' 9) "Filter" column added to column BB, "Player1" column added to column BC, "Player2" column added to column BD. Nothing is calculated in these
' columns. Only Headers added. Currently not a used function for this project.
'
With Range(Cells(2, lLastHTeamCol + 6), Cells(lLastRow, lLastHTeamCol + 6)) '
End With
'
With Range(Cells(2, lLastHTeamCol + 7), Cells(lLastRow, lLastHTeamCol + 7)) '
End With
'
With Range(Cells(2, lLastHTeamCol + 8), Cells(lLastRow, lLastHTeamCol + 8)) '
End With
Else '
MsgBox "No rows qualified for further testing." '
'
GoTo End_Sub
End If
'
'-------------------------------------------------------------------------------------------------------------------------------
'
' 10) Removes all helper columns - U:AU. "Salary" column becomes column U. "Projection" column becomes column V. "Stack" column becomes column W. "Stack POS"
' column becomes column X. "Stack 2" column becomes column Y. "Stack 2 POS" column becomes column Z. Filter column becomes column AA. "Player1" Column
' becomes column AB. "Player2" column becomes column AC.. A Dialogue Box then pops open and provides combination info: Possible combinations,
' unique combinations, duplicates removed, and the time to process. Data is then autofitted to the used range and printed to the "Worksheet".
' OptimizeCode_End is then called, which is just turning back on screen updating and whatnot.
'
' Remove Salary Columns
'
Range(Columns(lFirstHSortColumn), Columns(lLastHTeamCol)).Delete ' Delete columns V:AM ... 22 thru 39
'
If ComboID_Display = False Then Columns(lLastWriteColumn + 1).Delete ' Delete ComboID column if user chose not to see it
'
ActiveSheet.UsedRange.Columns.AutoFit '
'
Debug.Print "Wrapping up completed in:" & Space(124) & Format(Now() - StartTime, "hh:mm:ss") ' Display elapsed time for this process to the 'Immediate' window (CTRL+G) in VBE
'
Debug.Print vbLf & lLastIteration & vbTab & " possible combinations" & vbLf & lLastRow - 1 & vbTab & _
" unique name combinations" & vbLf & IIf(lLastRow < lLastRow, lLastRow - lLastRow & vbTab & _
" duplicate rows removed." & vbLf, "") & lLastRow - 1 & vbTab & " printed." & vbLf & vbLf & _
ExcessCombinations & " combinations were not displayed due to sheet restraints" & _
vbLf & vbLf & Format(Now() - dteStart, "hh:mm:ss") & " to process." '
'
MsgBox lLastIteration & vbTab & " possible combinations" & vbLf & lLastRow - 1 & vbTab & _
" unique name combinations" & vbLf & IIf(lLastRow < lLastRow, lLastRow - lLastRow & vbTab & _
" duplicate rows removed." & vbLf, "") & lLastRow - 1 & vbTab & " printed." & vbLf & vbLf & _
ExcessCombinations & " combinations were not displayed due to sheet restraints" & _
vbLf & vbLf & Format(Now() - dteStart, "hh:mm:ss") & " to process.", , "Output Report" '
'
End_Sub:
Call OptimizeCode_End
End Sub
Public Function ReDimPreserve(ArrayNameToResize, NewRowUbound, NewColumnUbound)
'
' Code inspired by Control Freak
'
' Preserve Original data & LBounds & Redim both dimensions for a 2D array
'
' example usage of the function:
' ArrayName = ReDimPreserve(ArrayName,NewRowSize,NewColumnSize)
' ie.
' InputArray = ReDimPreserve(InputArray,10,20)
'
Dim NewColumn As Long, NewRow As Long
Dim OldColumnLbound As Long, OldRowLbound As Long
Dim OldColumnUbound As Long, OldRowUbound As Long
Dim NewResizedArray() As Variant
'
ReDimPreserve = False
'
If IsArray(ArrayNameToResize) Then ' If the variable is an array then ...
OldRowLbound = LBound(ArrayNameToResize, 1) ' Save the original row Lbound to OldRowLbound
OldColumnLbound = LBound(ArrayNameToResize, 2) ' Save the original column Lbound to OldColumnLbound
'
ReDim NewResizedArray(OldRowLbound To NewRowUbound, OldColumnLbound To NewColumnUbound) ' Create a New 2D Array with same Lbounds as the original array
'
OldRowUbound = UBound(ArrayNameToResize, 1) ' Save row Ubound of original array
OldColumnUbound = UBound(ArrayNameToResize, 2) ' Save column Ubound of original array
'
For NewRow = OldRowLbound To NewRowUbound ' Loop through rows of original array
For NewColumn = OldColumnLbound To NewColumnUbound ' Loop through columns of original array
If OldRowUbound >= NewRow And OldColumnUbound >= NewColumn Then ' If more data to copy then ...
NewResizedArray(NewRow, NewColumn) = ArrayNameToResize(NewRow, NewColumn) ' Append rows/columns to NewResizedArray
End If
Next ' Loop back
Next ' Loop back
'
Erase ArrayNameToResize ' Free up the memory the Original array was taking
'
If IsArray(NewResizedArray) Then ReDimPreserve = NewResizedArray
End If
End Function
that sounds awesome! Look foward to seeing what you come up with. I'm in the midst of trying to figure out how to rank these lineups besides just projection as it isn't the greatest method. May post something to forums this week to see if anyone can help with insight on correlation.
