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 NameCombosV16c()
'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
Dim ExcessCombinations As Long
Dim lLastRow As Long
Dim lColumnIndex As Long
Dim lFirstHSortColumn As Long, lFirstHSortColumn2 As Long
Dim lFirstHTeamCol As Long, lLastHTeamCol As Long
Dim lFirstWriteColumn As Long, lLastWriteColumn As Long
Dim lIndex As Long
Dim lIterationCount As Long, lLastIteration As Long
Dim lLastColumn As Long
Dim lLastHSortColumn As Long, lLastHSortColumn2 As Long
Dim lLastSalaryRow As Long
Dim lLastUsedColumn As Long
Dim lWriteRow As Long
Dim MaxSalaryAllowed As Long
Dim SubArrayNumber As Long
Dim SubArrayColumn As Long, SubArrayRow As Long
Dim SubArrays As Long
Dim UniqueArrayRow As Long
Dim oSD As Object
Dim cel As Range
Dim rngFormulaRange As Range
Dim rngReplace As Range, rngReplace2 As Range, rngReplace3 As Range
Dim rngSortRange As Range
Dim SortRowRange As Range
Dim WorksheetNameRange As Range
Dim Delimiter As String
Dim oSD_KeyString As String
Dim sErrorMsg As String
Dim sMissingSalary As String
Dim sOutput As String
Dim arrOut() As Variant
Dim aryDeDupe As Variant
Dim aryNames As Variant
Dim JaggedArray() As Variant
Dim NoDupeRowArray() As Variant
Dim NoDupeSortedRowsArray() As Variant
Dim SalaryCalculationArray As Variant, SalaryCalcShortenedArray() As Variant
Dim SalarySheetFullArray As Variant, SalarySheetShortenedArray() As Variant
Dim TempArray As Variant
Dim UniqueWorksheetNamesArray As Variant
Dim varK As Variant
Dim WorksheetArray As Variant
Dim WorksheetColumnArray() As Variant
Dim names As Worksheet
Dim wks As Worksheet
Dim wksData As Worksheet
'
Const MaxCombinationRows As Long = 80000 ' <--- Set the MaxCombinationRows (100000) is probaly the max to be generated at a time
Const MaxNoDupeRowArrayRows As Long = 2100000 ' <--- Set the Max # rows we will possibly need
Const MaxRowsPerSubArray As Long = 80000 ' <--- Set the MaxRowsPerSubArray (100000) 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
varK = oSD.keys
'
For lIndex = LBound(varK) To UBound(varK)
sMissingSalary = sMissingSalary & ", " & varK(lIndex)
Next
'
sMissingSalary = Mid(sMissingSalary, 3)
'
sOutput = "The following names on the main worksheet do not have a corresponding entry on the 'Salary' worksheet." & vbLf & vbLf & sMissingSalary
'
MsgBox sOutput
Debug.Print sOutput
'
GoTo End_Sub
End If
'
Set oSD = CreateObject("Scripting.Dictionary") ' Erase contents of dictionary
Set oSD = Nothing ' Delete the dictionary
'
sErrorMsg = "Ensure a Worksheet is active with a header row starting in A1" & "and names under each header entry."
'
If TypeName(ActiveSheet) <> "Worksheet" Then
bShowError = True
End If
'
If bShowError Then
MsgBox sErrorMsg, , "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 lColumnIndex = 1 To lLastColumn
aryNames(1, lColumnIndex) = 2
aryNames(2, lColumnIndex) = Cells(Rows.Count, lColumnIndex).End(xlUp).Row
lLastIteration = lLastIteration * (aryNames(2, lColumnIndex) - 1)
Next
'
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 then write the
' combination of names & lIterationCount to NoDupeRowArray.
'
dteStart = Now()
StartTime = Now()
'
Application.StatusBar = "Step 1 of 6 ... Calculating name combinations & saving combinations with no duplicate names in same combination ..."
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 WorksheetArray
Set WorksheetNameRange = wksData.Range("A2:" & Split(Cells(1, lLastColumn).Address, "$")(1) & _
wksData.Range("A1").CurrentRegion.Find("*", , xlFormulas, , xlByRows, xlPrevious).Row)
WorksheetArray = WorksheetNameRange
'
Cells(1, lLastWriteColumn + 1).Value = "ComboID"
'
'Add Output Header
Range(Cells(1, 1), Cells(1, lLastColumn)).Copy Destination:=Cells(1, lFirstWriteColumn)
'
' 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) = WorksheetArray(ArrayRow, ArrayColumn) ' Save the data to WorksheetColumnArray()
Next ' Loop back
Next ' Loop back
'
'Start creating combinations
lIterationCount = 0 ' Reset lIterationCount
lWriteRow = 0 ' Reset lWriteRow
CurrentRow = 0 ' Reset WriteRow
'
ReDim TempArray(1 To MaxCombinationRows, 1 To lLastColumn + 2) ' Set up TempArray with rows = MaxCombinationRows & columns 2 more than data range
ReDim NoDupeRowArray(1 To MaxNoDupeRowArrayRows, 1 To UBound(TempArray, 2) - 1) ' Set the # of rows/columns for NoDupeRowArray
'
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 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
' Add formula to each row
Set rngFormulaRange = Range(Cells(2, lLastUsedColumn + 1), _
Cells(lLastRow, lLastUsedColumn + 1)) ' Set the Range to place formulas in
'
With rngFormulaRange
.Formula = "=MODE.MULT(MATCH($" & Split(Cells(1, _
lFirstWriteColumn).Address, "$")(1) & "2:$" & _
Split(Cells(1, lLastUsedColumn).Address, "$")(1) & "2,$" & _
Split(Cells(1, lFirstWriteColumn).Address, "$")(1) & "2:$" & _
Split(Cells(1, lLastUsedColumn).Address, "$")(1) & _
"2,0))" ' Formula to check for duplicates in same row
Application.Calculate '
.Value = .Value '
End With
'
' Load the data with formula results back into TempArray
TempArray = ActiveSheet.Cells(2, lFirstWriteColumn).Resize( _
UBound(TempArray, 1), UBound(TempArray, 2)) '
'
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 ...
CurrentRow = CurrentRow + 1 ' Increment CurrentRow, this is the
' ' row of the NoDupeRowArray
'
For ArrayColumn = 1 To UBound(TempArray, 2) - 1 ' Loop through columns of
' ' TempArray, except last column
NoDupeRowArray(CurrentRow, ArrayColumn) = _
TempArray(ArrayRow, ArrayColumn) ' Save values to NoDupeRowArray
Next ' Loop back
End If
Next ' Loop back
'
lWriteRow = 0 ' Reset lWriteRow for TempArray
'
ActiveSheet.Cells(2, lFirstWriteColumn).Resize(UBound(TempArray, 1), _
UBound(TempArray, 2)).ClearContents ' Clear the data range
'
ReDim TempArray(1 To MaxCombinationRows, 1 To lLastColumn + 2) ' Clear results from TempArray
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 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 the sheet
'
' Add formula to each row
Set rngFormulaRange = Range(Cells(2, lLastUsedColumn + 1), _
Cells(lLastRow, lLastUsedColumn + 1)) ' Set the Range to place formulas
'
With rngFormulaRange
.Formula = "=MODE.MULT(MATCH($" & Split(Cells(1, lFirstWriteColumn).Address, "$")(1) & "2:$" & _
Split(Cells(1, lLastUsedColumn).Address, "$")(1) & "2,$" & _
Split(Cells(1, lFirstWriteColumn).Address, "$")(1) & "2:$" & _
Split(Cells(1, lLastUsedColumn).Address, "$")(1) & "2,0))" ' Formula to check for duplicates in same row
Application.Calculate '
.Value = .Value '
End With
'
Set rngFormulaRange = Nothing
'
' Load the data with formula results back into TempArray
TempArray = ActiveSheet.Cells(2, lFirstWriteColumn).Resize(UBound(TempArray, 1), UBound(TempArray, 2)) '
'
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' ( No duplicates in row) then ...
CurrentRow = CurrentRow + 1 ' Increment CurrentRow, this is the row of the NoDupeRowArray
'
For ArrayColumn = 1 To UBound(TempArray, 2) - 1 ' Loop through columns of TempArray, except last column
NoDupeRowArray(CurrentRow, ArrayColumn) = TempArray(ArrayRow, ArrayColumn) ' Save values to NoDupeRowArray
Next ' Loop back
End If
Next ' Loop back
'
ActiveSheet.Cells(2, lFirstWriteColumn).Resize(UBound(TempArray, 1), UBound(TempArray, 2)).ClearContents ' Clear the data range
End If
'
Erase TempArray '
'
NoDupeRowArray = ReDimPreserve(NoDupeRowArray, CurrentRow, UBound(NoDupeRowArray, 2)) ' Resize NoDupeRowArray to correct the actual rows used in the array
'
Debug.Print "Create all combinations & remove rows with duplicate entries in the same row 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) = names in original order, 10 = ComboID
'
'-------------------------------------------------------------------------------------------------------------------------------
'
' 3) 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 2 of 6 ... Sorting remaining combination rows alphabetically by row ..."
DoEvents
'
' If UBound(NoDupeRowArray, 1) > Rows.Count Then ' If there are > total rows allowed on a sheet remaining then ...
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 arrOut(1 To MaxRowsPerSubArray, 1 To UBound(NoDupeRowArray, 2)) ' Reset the arrOut
'
For SubArrayRow = 1 To MaxRowsPerSubArray ' Loop through rows of arrOut
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
arrOut(SubArrayRow, ArrayColumn) = NoDupeRowArray(CurrentRow, ArrayColumn) ' Save column value into arrOut
Next ' Loop back
Next ' Loop back
'
JaggedArray(SubArrayNumber) = arrOut ' Save the arrOut to the JaggedArray
'
Erase arrOut
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 + 1)) ' Set the Range to be sorted
'
For Each SortRowRange In rngSortRange.Rows ' Loop through each row of the range to be sorted
SortRowRange.Sort Key1:=SortRowRange.Cells(1, 1), Order1:=xlAscending, _
Header:=xlNo, Orientation:=xlSortRows ' Sort each row alphabetically
Next ' Loop back
'
Set rngSortRange = Nothing
Set SortRowRange = 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
'
' At this point, the subArrays contain (ComboID) in column 1 and the sorted names in columns 2 thru 10 due to the sorting ;)
'
' Else ' Else ...
' ActiveSheet.Cells(2, lFirstWriteColumn).Resize(UBound(NoDupeRowArray, 1), _
UBound(NoDupeRowArray, 2)) = NoDupeRowArray ' Write NoDupeRowArray 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 + 1)) ' Set the Range to be sorted
'
' For Each SortRowRange In rngSortRange.Rows ' Loop through each row of the range to be sorted
' SortRowRange.Sort Key1:=SortRowRange.Cells(1, 1), Order1:=xlAscending, _
Header:=xlNo, Orientation:=xlSortRows ' Sort each row alphabetically
' Next ' Loop back
'
' At this point, the sheet contains (ComboID) in column 1 and the sorted names in columns 2 thru 10 due to the sorting ;)
' End If
'
Debug.Print "Sort remaining combination rows alphabetically by row completed " & _
"in:" & Space(27) & Format(Now() - StartTime, "hh:mm:ss") ' Display elapsed time for this process to the 'Immediate' window (CTRL+G) in VBE
'
'-------------------------------------------------------------------------------------------------------------------------------
'
' 4) Copy unique sorted rows from the subArrays to NoDupeSortedRowsArray
'
StartTime = Now()
'
Application.StatusBar = "Step 3 of 6 ... Removing duplicate sorted rows ..."
DoEvents
'
ReDim NoDupeSortedRowsArray(1 To UBound(NoDupeRowArray, 1), 1 To UBound(NoDupeRowArray, 2)) '
'
' If UBound(NoDupeRowArray, 1) > Rows.Count Then ' If there are > total rows allowed on a sheet remaining then ...
'
' 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 = 2 To UBound(JaggedArray(SubArrayNumber), 2) ' Loop through columns, except ComboID (first) column, 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 = 2 To UBound(JaggedArray(SubArrayNumber), 2) ' Loop through columns of JaggedArray(SubArrayNumber)
NoDupeSortedRowsArray(CurrentRow, ArrayColumn - 1) = _
JaggedArray(SubArrayNumber)(SubArrayRow, ArrayColumn) ' Save values to NoDupeRowArray
Next ' Loop back
'
NoDupeSortedRowsArray(CurrentRow, UBound(JaggedArray(SubArrayNumber), 2)) = _
JaggedArray(SubArrayNumber)(SubArrayRow, 1) ' Save ComboID to NoDupeSortedRowsArray
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(48) & _
Format(Now() - StartTime, "hh:mm:ss") & ", leaving " & UBound(NoDupeSortedRowsArray, 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 = ComboID
' Else '
' NoDupeSortedRowsArray = NoDupeRowArray '
'
' ActiveSheet.Cells(2, lFirstWriteColumn).Resize(UBound(NoDupeRowArray, 1), _
UBound(NoDupeRowArray, 2)) = NoDupeRowArray ' Write NoDupeRowArray to the sheet for sorting
'
' Debug.Print "Removal of duplicate sorted rows, leaving " & UBound(NoDupeRowArray, 1) & _
" rows, completed in " & Format(Now() - StartTime, "hh:mm:ss") ' Display elapsed time for this process to the 'Immediate' window (CTRL+G) in VBE
'
' End If
'
' At this point, the unique sorted rows have been written to NoDupeSortedRowsArray &
' NoDupeSortedRowsArray(1 thru 9) = names in sorted order, 10 = ComboID
'
'-------------------------------------------------------------------------------------------------------
'
' 5) 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 4 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) - 1 ' Loop through the columns of NoDupeRowArray except for the last column
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(19) & 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 = ComboID
'
'-------------------------------------------------------------------------------------------------------
'
' 6) Copy data on sheet to next set of columns. Insert a column for the salary total of each row. Save the unique
' names from the 'Worksheet' into UniqueWorksheetNamesArray. Save respective data from 'Salary' sheet into
' SalarySheetShortenedArray. Replace copied names in column U:AC with the players respective
' salary data in SalarySheetShortenedArray. Sum the salaries from each of those rows & save results into
' the added Salary column.
'
StartTime = Now()
'
Application.StatusBar = "Step 5 of 6 ... Removing all combination rows with salaries > " & MaxSalaryAllowed & " ..."
DoEvents
'
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 same size as 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 the name from UniqueWorksheetNamesArray is found in
' ' SalarySheetFullArray then ...
CurrentRow = CurrentRow + 1 ' Increment CurrentRow
'
For lColumnIndex = 1 To UBound(SalarySheetFullArray, 2) ' Loop through the columns of SalarySheetFullArray
SalarySheetShortenedArray(CurrentRow, lColumnIndex) = _
SalarySheetFullArray(ArrayRow, lColumnIndex) ' Save the values to SalarySheetShortenedArray
Next ' Loop back
End If
Next ' Loop back
Next ' Loop back
'
Erase SalarySheetFullArray
'
SalarySheetShortenedArray = ReDimPreserve(SalarySheetShortenedArray, CurrentRow, _
UBound(SalarySheetShortenedArray, 2)) ' Resize SalarySheetShortenedArray to correct the actual rows used in the array
'
'-----------------
'
SubArrays = Int((UBound(NoDupeSortedRowsArray, 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 arrOut(1 To MaxRowsPerSubArray, 1 To UBound(NoDupeSortedRowsArray, 2)) ' Reset the arrOut
'
For SubArrayRow = 1 To MaxRowsPerSubArray ' Loop through rows of arrOut
CurrentRow = CurrentRow + 1 ' Increment CurrentRow, this is the row of the NoDupeRowArray
'
If CurrentRow > UBound(NoDupeSortedRowsArray, 1) Then Exit For ' If all of the rows have been processed then exit this For loop
'
For ArrayColumn = 1 To UBound(NoDupeSortedRowsArray, 2) ' Loop through columns of NoDupeRowArray
arrOut(SubArrayRow, ArrayColumn) = NoDupeSortedRowsArray(CurrentRow, ArrayColumn) ' Save column value into arrOut
Next ' Loop back
Next ' Loop back
'
JaggedArray(SubArrayNumber) = arrOut ' Save the arrOut to the JaggedArray
'
Erase arrOut
Next ' Loop back
'
' At this point, all of the remaining combinations have been loaded into the JaggedArray subArrays
'
'-----------------
'
' Write each subArray to the sheet, do salary calculations & save results back into the subArray
'
ReDim SalaryCalcShortenedArray(1 To UBound(NoDupeSortedRowsArray, 1), _
1 To UBound(NoDupeSortedRowsArray, 2) + 1) ' Set the # of rows/columns for SalaryCalcShortenedArray
'
CurrentRow = 0 ' Initialize CurrentRow
'
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
'
lLastRow = Cells(Rows.Count, lFirstWriteColumn).End(xlUp).Row '
'
Columns(lLastUsedColumn).Insert ' Insert column 20 ... U for the 'Salary'
'
' Add Sum Column
Cells(1, lLastUsedColumn).Value = ChrW(931) & " Salary" ' 20 ... T
'
Set rngReplace = Range(Cells(2, lFirstWriteColumn), Cells(lLastRow, lLastWriteColumn)) '
'
For ArrayRow = 1 To UBound(SalarySheetShortenedArray, 1) ' Loop through rows of SalarySheetShortenedArray
rngReplace.Replace What:=SalarySheetShortenedArray(ArrayRow, 1), _
Replacement:=SalarySheetShortenedArray(ArrayRow, 2), LookAt:=xlWhole, _
SearchOrder:=xlByRows, MatchCase:=False, SearchFormat:=False, ReplaceFormat:=False '
Next ' Loop back
'
Set rngReplace = Nothing
'
With Range(Cells(2, lLastUsedColumn), Cells(lLastRow, lLastUsedColumn))
.FormulaR1C1 = "=SUM(RC" & lFirstWriteColumn & ":RC" & lLastWriteColumn & ")" '
Application.Calculate '
.Value = .Value '
End With
'
'-------------------------------------------------------------------------------------------------------------------------------
'
' 7) Save the 'Salary' range of data into SalaryCalculationArray. Save allowable salary rows into SalaryCalcShortenedArray.
' Match the ComboIDs for each row saved to the ComboIDs in NoDupeSortedRowsArray so we can replace the
' respective names to the salaries.
'
SalaryCalculationArray = Range(Cells(2, lFirstWriteColumn), Cells(lLastRow, lLastUsedColumn + 1)) '
'
For ArrayRow = LBound(SalaryCalculationArray, 1) To UBound(SalaryCalculationArray, 1) ' Loop through rows of SalaryCalculationArray
If SalaryCalculationArray(ArrayRow, UBound(SalaryCalculationArray, 2) - 1) _
<= MaxSalaryAllowed Then ' If we have an allowable salary then ...
CurrentRow = CurrentRow + 1 ' Increment CurrentRow
'
For ArrayColumn = LBound(SalaryCalculationArray, 2) To UBound(SalaryCalculationArray, 2) ' Loop through the columns of SalaryCalculationArray
SalaryCalcShortenedArray(CurrentRow, ArrayColumn) = _
SalaryCalculationArray(ArrayRow, ArrayColumn) ' Save the data from the row to SalaryCalcShortenedArray
Next ' Loop back
End If
Next ' Loop back
'
Erase SalaryCalculationArray
'
ActiveSheet.Cells(2, lFirstWriteColumn).Resize(UBound(JaggedArray(SubArrayNumber), 1), _
UBound(JaggedArray(SubArrayNumber), 2) + 1).ClearContents ' Clear the calculation range
'
Columns(lLastUsedColumn).EntireColumn.Delete '
'
Erase JaggedArray(SubArrayNumber)
Next ' Loop back
'
Erase JaggedArray
'
SalaryCalcShortenedArray = ReDimPreserve(SalaryCalcShortenedArray, CurrentRow, _
UBound(SalaryCalcShortenedArray, 2)) '
'
' Replace the individual Salary amounts with the original individual names by matching up the ComboIDs
CurrentRow = 1 ' Initialize CurrentRow
'
For ArrayRow = LBound(NoDupeSortedRowsArray, 1) To UBound(NoDupeSortedRowsArray, 1) ' Loop through rows of NoDupeSortedRowsArray
If NoDupeSortedRowsArray(ArrayRow, UBound(NoDupeSortedRowsArray, 2)) = _
SalaryCalcShortenedArray(CurrentRow, UBound(SalaryCalcShortenedArray, 2)) Then ' If we found matching ComboID's then ...
For ArrayColumn = LBound(NoDupeSortedRowsArray, 2) To UBound(NoDupeSortedRowsArray, 2) - 1 ' Loop through the columns of NoDupeSortedRowsArray except for the last column
SalaryCalcShortenedArray(CurrentRow, ArrayColumn) = _
NoDupeSortedRowsArray(ArrayRow, ArrayColumn) ' Save the name from the row/column to SalaryCalcShortenedArray
Next ' Loop back
'
CurrentRow = CurrentRow + 1 ' Increment CurrentRow
'
If CurrentRow > UBound(SalaryCalcShortenedArray, 1) Then Exit For '
End If
Next ' Loop back
'
'
' At this point, all criteria for deletion of combination rows have been completed
'
Erase NoDupeSortedRowsArray
'
' Add Sum Column
Columns(lLastUsedColumn).Insert ' Insert column for the 'Salary'
'
Cells(1, lLastUsedColumn).Value = ChrW(931) & " Salary" ' 20 ... T
'
If UBound(SalaryCalcShortenedArray, 1) > Rows.Count Then ' If the remaining amount of combinations> 1048576 then ...
ExcessCombinations = UBound(SalaryCalcShortenedArray, 1) - Rows.Count ' Calculate the remaining combinations that will not be printed
'
SalaryCalcShortenedArray = ReDimPreserve(SalaryCalcShortenedArray, Rows.Count, _
UBound(SalaryCalcShortenedArray, 2)) ' Limit the displayed rows to the sheet allowable range, discard the rest of the combos
End If
'
Cells(2, lFirstWriteColumn).Resize(UBound(SalaryCalcShortenedArray, 1), _
UBound(SalaryCalcShortenedArray, 2)) = SalaryCalcShortenedArray ' Display SalaryCalcShortenedArray to 'Worksheet'
'
' 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
'
Debug.Print "Remove all combinations with salaries > " & MaxSalaryAllowed & " completed in:" & _
Space(35) & Format(Now() - StartTime, "hh:mm:ss") & ", leaving " & _
UBound(SalaryCalcShortenedArray, 1) & " combination rows" ' Display elapsed time for this process to the 'Immediate' window (CTRL+G) in VBE
'
Erase SalaryCalcShortenedArray
' Else
' End If
'
'-------------------------------------------------------------------------------------------------------------------------------
'
' 8) 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
'
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
'
lFirstHTeamCol = lLastHSortColumn + 1 ' 31 ... AE
lLastHTeamCol = Cells(1, Columns.Count).End(xlToLeft).Column ' 39 ... AM
'
Set rngReplace2 = Range(Cells(2, lFirstHSortColumn), Cells(lLastRow, lLastHSortColumn)) ' 22 ... V ... 30 ... AD
Set rngReplace3 = Range(Cells(2, lFirstHTeamCol), Cells(lLastRow, lLastHTeamCol)) ' 31 ... AE ... 39 ... AM
'
For ArrayRow = 1 To UBound(SalarySheetShortenedArray, 1) ' Loop through rows of SalarySheetShortenedArray
'
'''''''''''''''''''''''''''''''''''''PROJECTION
rngReplace2.Replace What:=SalarySheetShortenedArray(ArrayRow, 1), _
Replacement:=SalarySheetShortenedArray(ArrayRow, 3), LookAt:=xlWhole, _
SearchOrder:=xlByRows, MatchCase:=False, SearchFormat:=False, ReplaceFormat:=False '
'
'
'''''''''''''''''''''''''''''''''''''TEAM
rngReplace3.Replace What:=SalarySheetShortenedArray(ArrayRow, 1), _
Replacement:=SalarySheetShortenedArray(ArrayRow, 4), LookAt:=xlWhole, _
SearchOrder:=xlByRows, MatchCase:=False, SearchFormat:=False, ReplaceFormat:=False '
Next ' Loop back
'
Set rngReplace2 = Nothing
Set rngReplace3 = Nothing
'
' 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 '
'
sOutput = 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." '
'
Debug.Print "Wrapping up completed in:" & Space(69) & Format(Now() - StartTime, "hh:mm:ss") ' Display elapsed time for this process to the 'Immediate' window (CTRL+G) in VBE
'
Debug.Print vbLf & sOutput '
MsgBox sOutput, , "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
Extremely happy with the results and couldn't ask for anything more! The removal of salary before adding to sheet helps tremendously in getting more combinations. Thank you thank you johnnyL!
