Help with max rows of a million+

cspengel

Board Regular
Joined
Oct 29, 2022
Messages
173
Office Version
  1. 365
  2. 2021
Platform
  1. Windows
Back again...

I need assistance with my macro as I am running into issues with the max rows exceeding 1,048,576.

The macros current method in order:

-writes a combination of names
-once names are written, it then copies those names into helper columns and replaces the names with a salary
-adds salary together in a new column
-sorts names in order
-removes duplicates

I have enough filters where the number of rows in the end will never exceed 1,048,576...however the macro still has to "write" the names and salaries to determine if it meets criteria. The removal of duplicates and salary over 60000 doesn't occur until after all the combinations are all written. Is there any way for me to continue with the rest of code if max rows written is reached and then loop back to start writing the combinations again... Thanks for any assistance


VBA Code:
Public CalcState As Long
Public EventState As Boolean
Public PageBreakState As Boolean

Sub OptimizeCode_Begin()

Application.ScreenUpdating = False

EventState = Application.EnableEvents
Application.EnableEvents = False

CalcState = Application.Calculation
Application.Calculation = xCalculationManual

PageBreakState = ActiveSheet.DisplayPageBreaks
ActiveSheet.DisplayPageBreaks = False

End Sub

Sub OptimizeCode_End()

ActiveSheet.DisplayPageBreaks = PageBreakState
Application.Calculation = CalcState
Application.EnableEvents = EventState
Application.ScreenUpdating = True

End Sub


Sub NameCombos()
    'https://www.mrexcel.com/forum/excel-questions/1106189-all-combinations-multiple-columns-without-duplicates.html
    
    Dim lLastColumn As Long
    Dim lLastUsedColumn As Long
    Dim aryNames As Variant
    Dim lColumnIndex As Long
    Dim lWriteRow As Long
    Dim bCarry As Boolean
    Dim lWriteColumn As Long
    Dim rngWrite As Range
    Dim lFirstWriteColumn As Long
    Dim lLastWriteColumn As Long
    Dim oFound As Object
    Dim lRefColumn As Long
    Dim lInUseRow As Long
    Dim lCarryColumn As Long
    Dim lPrint As Long
    Dim lLastIteration As Long
    Dim lIterationCount As Long
    Dim sErrorMsg As String
    Dim bShowError As Boolean
    Dim lLastRow As Long
    Dim lLastRowDeDuped As Long
    Dim aryDeDupe As Variant
    Dim s As Long
    Dim sRow As Long
    Dim x As Long
    Dim wksData As Worksheet
    Dim rngDataBlock As Range
    Dim lngLastRow As Long, lngLastCol As Long
    
    Dim sName As String
    Dim bDupeName As Boolean
    
    Dim oSD As Object
    Dim rngCell As Range
    Dim varK As Variant, varI As Variant, varTemp As Variant, lIndex As Long
    Dim lRowIndex As Long
    Dim lRowIndex2 As Long
    Dim rngSortRange As Range
    Dim dteStart As Date
    Dim sOutput As String
    Dim lFirstHSortColumn As Long
    Dim lFirstHSortColumn2 As Long
    Dim lFirstHTeamCol As Long
    Dim firstrow As Long
    Dim v
    Dim lLastHTeamCol As Long
    Dim currow As Long
    Dim diff As Long
    Dim lLastHSortColumn As Long
    Dim lLastHSortColumn2 As Long
    Dim lLastSalaryRow As Long
    Dim rngReplace As Range
    Dim wks As Worksheet
    Dim bFoundSalary As Boolean
    Dim sMissingSalary As String
    Dim names As Worksheet

    
    Call OptimizeCode_Begin
    
    Application.StatusBar = False
    Set wksData = ThisWorkbook.Sheets("Worksheet")
    Set names = Sheets("Salary")
    '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 rngCell In ActiveSheet.Range("A1").CurrentRegion.Offset(1, 0)
        rngCell.Value = Trim(rngCell.Value)
        If rngCell.Value <> vbNullString Then
            oSD.Item(rngCell.Value) = oSD.Item(rngCell.Value) + 1
        End If
    Next
    'Remove names on the Salary worksheet
    With Worksheets("Salary")
        For Each rngCell In .Range("A2:A" & .Cells(Rows.Count, 1).End(xlUp).Row)
            rngCell.Value = Trim(rngCell.Value)
            If oSD.exists(rngCell.Value) Then
                oSD.Remove rngCell.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
    
    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
    
    lRefColumn = lLastColumn + 1
    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 + vbCritical + _
        vbDefaultButton2, "Process table?")
    Case vbCancel
        GoTo End_Sub
    End Select
    
    dteStart = Now()
    
    'Clear all columns right of input range
    If lLastUsedColumn > lLastColumn Then
        Range(Cells(1, lLastColumn + 1), Cells(1, lLastUsedColumn)).EntireColumn.ClearContents
    End If
    Cells(1, lLastWriteColumn + 1).Value = "ComboID"
    
    'Add Output Header
    Range(Cells(1, 1), Cells(1, lLastColumn)).Copy Destination:=Cells(1, lFirstWriteColumn)
    
    'Start checking combinations
    lWriteRow = 2
    For lIterationCount = 1 To lLastIteration
        If lIterationCount / 1000 = lIterationCount \ 1000 Then Application.StatusBar = _
            lIterationCount & " / " & lLastIteration
            
        'Reset the Dupe Name flag
        bDupeName = False
        
        'Check Active Combo for Dupe Names
        'Initialize the scripting dictionary
        Set oSD = CreateObject("Scripting.Dictionary")
        oSD.CompareMode = vbTextCompare
        
        'Load names into scripting dictionary
        For lColumnIndex = lLastColumn To 1 Step -1
            sName = Cells(aryNames(1, lColumnIndex), lColumnIndex).Value
            oSD.Item(sName) = oSD.Item(sName) + 1
        Next
        
        'If there are names, and at least one duplicate, set the bDupeName flag
        If oSD.Count > 0 Then
            varK = oSD.keys
            varI = oSD.Items
            For lIndex = 1 To oSD.Count
                If varI(lIndex - 1) > 1 Then
                    bDupeName = True: Exit For
                End If
            Next
        End If
        
        
        If Not bDupeName Then
            'The current row had names and no duplicates
            'Print Active Combo to the lWriteRow row
            For lColumnIndex = lLastColumn To 1 Step -1
                lWriteColumn = lColumnIndex + lLastColumn + 2
                Set rngWrite = Range(Cells(lWriteRow, lFirstWriteColumn), Cells(lWriteRow, lLastWriteColumn))
                Cells(lWriteRow, lRefColumn + lColumnIndex).Value = Cells(aryNames(1, lColumnIndex), lColumnIndex).Value
            Next
            
            'Uncomment next row to see the lIterationCount for the printed row
            Cells(lWriteRow, lLastWriteColumn + 1).Value = lIterationCount
            
            'Point to the next blank row
            lWriteRow = lWriteRow + 1
            
        End If
    
        'Increment Counters
        'Whether the line had duplicates or not, move to the next name in the
        '  rightmost column, if it was ag the last name, go to the first name in that column and
        '  move the name in the column to the left down to the next name (recursive check if THAT
        '  column was already using the last name for remaining columns to the left)
        aryNames(1, lLastColumn) = aryNames(1, lLastColumn) + 1
        If aryNames(1, lLastColumn) > aryNames(2, lLastColumn) Then
            bCarry = True
            lCarryColumn = lLastColumn
            Do While bCarry = True And lCarryColumn > 0
                aryNames(1, lCarryColumn) = 2
                bCarry = False
                lCarryColumn = lCarryColumn - 1
                If lCarryColumn = 0 Then Exit Do
                aryNames(1, lCarryColumn) = aryNames(1, lCarryColumn) + 1
                If aryNames(1, lCarryColumn) > aryNames(2, lCarryColumn) Then bCarry = True
            Loop
        End If
        
        'Check counter values (for debug)
'        Debug.Print lWriteRow,
'        For lPrint = 1 To lLastColumn
'            Debug.Print aryNames(1, lPrint) & ", ";
'        Next
'        Debug.Print
        DoEvents
    Next
    
    Application.StatusBar = "Sorting"
    Application.ScreenUpdating = False
    
    'Copy row names to right so that each copied row can be sorted alphabetically left to right
    '  this will allow the Excel remove duplicate fuction to remove rows that have identical names
    '  in all of their sorted columns.
    lLastRow = Cells(Rows.Count, lFirstWriteColumn).End(xlUp).Row
    Range(Cells(1, lFirstWriteColumn), Cells(lLastRow, lLastWriteColumn)).Copy Destination:=Cells(1, lLastWriteColumn + 2) ''SALARY
    lFirstHSortColumn = lLastWriteColumn + 2
    lLastHSortColumn = Cells(1, Columns.Count).End(xlToLeft).Column
    
    Range(Cells(1, lFirstWriteColumn), Cells(lLastRow, lLastWriteColumn)).Copy Destination:=Cells(1, lLastHSortColumn + 1) ''PROJECTION
    lFirstHSortColumn2 = lLastHSortColumn + 1
    lLastHSortColumn2 = Cells(1, Columns.Count).End(xlToLeft).Column
     
    Range(Cells(1, lFirstWriteColumn), Cells(lLastRow, lLastWriteColumn)).Copy Destination:=Cells(1, lLastHSortColumn2 + 1) ''TEAM
    lFirstHTeamCol = lLastHSortColumn2 + 1
    lLastHTeamCol = Cells(1, Columns.Count).End(xlToLeft).Column
     
        
    
       'Assumes the 'Salary' worksheet has names in the column A and salaries in column B starting in row 2
    'Replace HSort names with salary
    With Worksheets("Salary") '''' SALARY
        lLastSalaryRow = .Cells(.Rows.Count, 1).End(xlUp).Row
    End With
    Set rngReplace = Range(Cells(2, lFirstHSortColumn), Cells(lLastRow, lLastHSortColumn))
    For lRowIndex = 2 To lLastSalaryRow
        rngReplace.Replace What:=Worksheets("Salary").Cells(lRowIndex, 1).Value, _
            Replacement:=Worksheets("Salary").Cells(lRowIndex, 2).Value, LookAt:=xlWhole, _
            SearchOrder:=xlByRows, MatchCase:=False, SearchFormat:=False, _
            ReplaceFormat:=False
     Next
     lLastRowDeDuped = Cells(Rows.Count, lFirstWriteColumn).End(xlUp).Row
     'Add Sum Column
   Cells(1, lLastHTeamCol + 1).Value = ChrW(931) & " Salary"
    With Range(Cells(2, lLastHTeamCol + 1), Cells(lLastRowDeDuped, lLastHTeamCol + 1))
        .FormulaR1C1 = "=SUM(RC" & lFirstHSortColumn & ":RC" & lLastHSortColumn & ")"
        Application.Calculate
        .Value = .Value
        End With
        
   lLastRow = Cells(Rows.Count, lFirstWriteColumn).End(xlUp).Row
        
        With wksData
        .Range("A2:I26").Cut names.Range("G2")
        Application.CutCopyMode = False
      End With
        With wksData
        'Start from cell A1 (1, 1) and assign to the last row and last column
        Set rngDataBlock = .Range(.Cells(1, lLastHTeamCol + 1), .Cells(lLastRow, lLastHTeamCol + 1))
    End With
        x = 60000
        Application.DisplayAlerts = False
        With rngDataBlock
            .AutoFilter Field:=1, Criteria1:=">" & x
            On Error Resume Next
            .Range(Cells(2, lFirstWriteColumn), Cells(lLastRow, lLastHTeamCol + 9)).Delete Shift:=xlUp
        End With
    Application.DisplayAlerts = True
    
    With names
    .Range("G2:O26").Cut wksData.Range("A2")
    Application.CutCopyMode = False
    End With

     
    'Turn off the Autofilter safely
    With wksData
        .AutoFilterMode = False
        If .FilterMode = True Then
            .ShowAllData
        End If
    End With
      
     
    'Sort each row
    Application.ScreenUpdating = False
    lLastRow = Cells(Rows.Count, lFirstWriteColumn).End(xlUp).Row
    For lRowIndex = 2 To lLastRow
        Set rngSortRange = Range(Cells(lRowIndex, lFirstHSortColumn), Cells(lRowIndex, lLastHSortColumn))
        ActiveSheet.Sort.SortFields.Clear
        ActiveSheet.Sort.SortFields.Add Key:=rngSortRange, _
            SortOn:=xlSortOnValues, Order:=xlAscending, DataOption:=xlSortNormal
        With ActiveSheet.Sort
            .SetRange rngSortRange
            .Header = xlNo
            .MatchCase = False
            .Orientation = xlLeftToRight
            .SortMethod = xlPinYin
            .Apply
        End With
    Next
    
    'Check for duplicate rows in HSort Columns
    '  Can only happen if names are duplicated within an input column
    '  Build aryDeDupe  -- Array(1, 2, 3,...n)  -- to exclude iteration # column

    lLastRow = Cells(Rows.Count, lFirstWriteColumn).End(xlUp).Row
    ReDim aryDeDupe(0 To lLastHSortColumn - lFirstHSortColumn)
    lIndex = 0
    For lColumnIndex = lFirstHSortColumn To lLastHSortColumn
        aryDeDupe(lIndex) = CInt(lColumnIndex - lFirstWriteColumn + 1)
        lIndex = lIndex + 1
    Next
    ActiveSheet.Cells(1, lFirstWriteColumn).CurrentRegion.RemoveDuplicates Columns:=(aryDeDupe), Header:=xlYes
    'Above line won't work unless there are parens around the Columns argument ?????
    
    lLastRowDeDuped = Cells(Rows.Count, lFirstWriteColumn).End(xlUp).Row
    
    
     '''''''''''''''''''''''''''''''''''''PROJECTION
     With Worksheets("Salary")
        lLastSalaryRow = .Cells(.Rows.Count, 1).End(xlUp).Row
    End With
    Set rngReplace = Range(Cells(2, lFirstHSortColumn2), Cells(lLastRow, lLastHSortColumn2))
    For lRowIndex2 = 2 To lLastSalaryRow
        rngReplace.Replace What:=Worksheets("Salary").Cells(lRowIndex2, 1).Value, _
            Replacement:=Worksheets("Salary").Cells(lRowIndex2, 3).Value, LookAt:=xlWhole, _
            SearchOrder:=xlByRows, MatchCase:=False, SearchFormat:=False, _
            ReplaceFormat:=False
    Next '''''''''''''''''''''''''''
    
         '''''''''''''''''''''''''''''''''''''TEAM
     With Worksheets("Salary")
        lLastSalaryRow = .Cells(.Rows.Count, 1).End(xlUp).Row
    End With
    Set rngReplace = Range(Cells(2, lFirstHTeamCol), Cells(lLastRow, lLastHTeamCol))
    For lRowIndex2 = 2 To lLastSalaryRow
        rngReplace.Replace What:=Worksheets("Salary").Cells(lRowIndex2, 1).Value, _
            Replacement:=Worksheets("Salary").Cells(lRowIndex2, 4).Value, LookAt:=xlWhole, _
            SearchOrder:=xlByRows, MatchCase:=False, SearchFormat:=False, _
            ReplaceFormat:=False
    Next '''''''''''''''''''''''''''
    
    
    ''Add Projection Column
    Cells(1, lLastHTeamCol + 2).Value = ChrW(931) & " Projection"
    With Range(Cells(2, lLastHTeamCol + 2), Cells(lLastRowDeDuped, lLastHTeamCol + 2))
        .FormulaR1C1 = "=SUM(RC" & lFirstHSortColumn2 & ":RC" & lLastHSortColumn2 & ")"
        Application.Calculate
        .Value = .Value
    End With
    
     ''Add Team Stack Column
    Cells(1, lLastHTeamCol + 3).Value = ChrW(931) & " Stack"
    With Range(Cells(2, lLastHTeamCol + 3), Cells(lLastRowDeDuped, lLastHTeamCol + 3))
        .FormulaR1C1 = "=INDEX(RC" & lFirstHTeamCol & ":RC" & lLastHTeamCol & ",MODE(MATCH(RC" & lFirstHTeamCol & ":RC" & lLastHTeamCol & ",RC" & lFirstHTeamCol & ":RC" & lLastHTeamCol & ",0)))"
        Application.Calculate
        .Value = .Value
    End With
    
    ''Add Team Stack Pos
    Cells(1, lLastHTeamCol + 4).Value = ChrW(931) & " Stack POS"
    With Range(Cells(2, lLastHTeamCol + 4), Cells(lLastRowDeDuped, lLastHTeamCol + 4))
    
    .Formula2R1C1 = "=TEXTJOIN("","",1,IF(RC[-12]:RC[-4]=RC[-1],R1C[-12]:R1C[-4],""""))"
        Application.Calculate
        .Value = .Value
    End With
    
    ''Add 2nd Team Stack Column
    Cells(1, lLastHTeamCol + 5).Value = ChrW(931) & " Stack2"
    With Range(Cells(2, lLastHTeamCol + 5), Cells(lLastRowDeDuped, lLastHTeamCol + 5))
        .Formula2R1C1 = "=IFERROR(INDEX(RC[-13]:RC[-5],MODE(IF((RC[-13]:RC[-5]<>"""")*(RC[-13]:RC[-5]<>INDEX(RC[-13]:RC[-5],MODE(IF(RC[-13]:RC[-5]<>"""",MATCH(RC[-13]:RC[-5],RC[-13]:RC[-5],0))))),MATCH(RC[-13]:RC[-5],RC[-13]:RC[-5],0)))),"""")"
        Application.Calculate
        .Value = .Value
    End With
    
    ''Add 2nd Team Stack Pos
    Cells(1, lLastHTeamCol + 6).Value = ChrW(931) & " Stack2 POS"
    With Range(Cells(2, lLastHTeamCol + 6), Cells(lLastRowDeDuped, lLastHTeamCol + 6))
    
    .Formula2R1C1 = "=TEXTJOIN("","",1,IF(RC[-12]:RC[-4]=RC[-1],R1C[-12]:R1C[-4],""""))"
        Application.Calculate
        .Value = .Value
    End With
    
    'Filter 0-1
    Cells(1, lLastHTeamCol + 7).Value = ChrW(931) & " Filter"
    With Range(Cells(2, lLastHTeamCol + 7), Cells(lLastRowDeDuped, lLastHTeamCol + 7))
    
    End With
    
    'Player 1 Filter
    Cells(1, lLastHTeamCol + 8).Value = ChrW(931) & " Player1"
    With Range(Cells(2, lLastHTeamCol + 8), Cells(lLastRowDeDuped, lLastHTeamCol + 8))
    
    End With
    
    'Player 2 Filter
    Cells(1, lLastHTeamCol + 9).Value = ChrW(931) & " Player2"
    With Range(Cells(2, lLastHTeamCol + 9), Cells(lLastRowDeDuped, lLastHTeamCol + 9))
    
    End With
   
    
    'Remove Salary Columns
    Range(Cells(2, lFirstHSortColumn), Cells(lLastRowDeDuped, lLastHTeamCol)).EntireColumn.Delete

    
    
    sOutput = lLastIteration & vbTab & " possible combinations" & vbLf & _
        lLastRow - 1 & vbTab & " unique name combinations" & vbLf & _
        IIf(lLastRowDeDuped <> lLastRow, lLastRow - lLastRowDeDuped & vbTab & " duplicate rows removed." & vbLf, "") & _
        lLastRowDeDuped - 1 & vbTab & " printed." & vbLf & vbLf & _
        Format(Now() - dteStart, "hh:mm:ss") & " to process."
    
    ActiveSheet.UsedRange.Columns.AutoFit
    MsgBox sOutput, , "Output Report"
    Debug.Print sOutput
        
End_Sub:
    Call OptimizeCode_End
    Application.StatusBar = False
    
End Sub
 

Excel Facts

Will the fill handle fill 1, 2, 3?
Yes! Type 1 in a cell. Hold down Ctrl while you drag the fill handle.
Sorry, can't stay away for some reason. ;(

Should be able to make it about 25% faster yet if my current thinking pans out.
 
Upvote 0
Boy was I off in my estimation of speed increase, it is looking like it will be about 300% faster. :)

I need to do some cleanup now and will post back later.
 
Upvote 0
Boy was I off in my estimation of speed increase, it is looking like it will be about 300% faster. :)

I need to do some cleanup now and will post back later.
Must be that feeling of always wanting to see how you can improve something 😁 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.
 
Upvote 0
Rich (BB code):
Create all combinations & remove rows with duplicate entries in the same row completed in:    00:00:18, leaving 505440 combination rows.
Sort remaining combination rows alphabetically by row completed in:                           00:01:42
Removal of duplicate sorted rows completed in:                                                00:00:11, leaving 214813 combination rows.
Restore Original order of names in the remaining combinations completed in:                   00:00:01
Remove all combinations with salaries > 60000 completed in:                                   00:00:38, leaving 60533 combination rows
Wrapping up completed in 00:00:23

786240   possible combinations
60533    unique name combinations
60533    printed.

00:03:13 to process.

Results from newest code:
Rich (BB code):
Create all combinations & remove rows with duplicate name entries in the same row & & remove all combinations with salaries > 60000 completed in:    00:00:31, leaving 78414 combination rows.
Restore Original order of names in the remaining combinations completed in:                                                                          00:00:00
Sort remaining combination rows alphabetically by row completed in:                                                                                  00:00:15
Removal of duplicate sorted rows completed in:                                                                                                       00:00:02, leaving 60533 combination rows.
Restore Original order of names in the remaining combinations completed in:                                                                          00:00:00
Wrapping up completed in:                                                                                                                            00:00:06

786240   possible combinations
60533    unique name combinations
60533    printed.

0 combinations were not displayed due to sheet restraints

00:00:54 to process.

Rich (BB code):
Create all combinations & remove rows with duplicate entries in the same row completed in:    00:01:13, leaving 2021760 combination rows.
Sort remaining combination rows alphabetically by row completed in:                           00:07:06
Removal of duplicate sorted rows completed in:                                                00:04:09, leaving 859249 combination rows.
Restore Original order of names in the remaining combinations completed in:                   00:00:02
Remove all combinations with salaries > 60000 completed in:                                   00:02:44, leaving 364253 combination rows
Wrapping up completed in:                                                                     00:02:21

3144960  possible combinations
364253   unique name combinations
364253   printed.

0 combinations were not displayed due to sheet restraints

00:17:36 to process.

Results from newest code:
Rich (BB code):
Create all combinations & remove rows with duplicate name entries in the same row & & remove all combinations with salaries > 60000 completed in:    00:02:06, leaving 531008 combination rows.
Restore Original order of names in the remaining combinations completed in:                                                                          00:00:02
Sort remaining combination rows alphabetically by row completed in:                                                                                  00:01:37
Removal of duplicate sorted rows completed in:                                                                                                       00:00:24, leaving 364253 combination rows.
Restore Original order of names in the remaining combinations completed in:                                                                          00:00:01
Wrapping up completed in:                                                                                                                            00:00:38

3144960  possible combinations
364253   unique name combinations
364253   printed.

0 combinations were not displayed due to sheet restraints

00:04:48 to process.

I haven't done the exact math but that appears to be like about a 350% increase in speed over the code posted in post #122


There are many changes in the newest code that I came up with, I would have to say that the biggest time saver was changing all of the 'replace' sections of code with a version of code that does the 'replacements' to the values in an array as opposed to doing it on the sheet.

Please try the newest code out & let me know what you think. There is still a memory hog in the code that I haven't tracked down yet. So you will have to close excel & reopen it each time you run the code.

VBA Code:
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
 
Upvote 0
Solution
Wow that is a heck of an improvement!! 😃

I'll be sure to give it a go and let ya know after all the family stuff tomorrow/today. Thanks 😊
 
Upvote 0
Results from newest code:
Rich (BB code):
Create all combinations & remove rows with duplicate name entries in the same row & & remove all combinations with salaries > 60000 completed in:    00:00:31, leaving 78414 combination rows.
Restore Original order of names in the remaining combinations completed in:                                                                          00:00:00
Sort remaining combination rows alphabetically by row completed in:                                                                                  00:00:15
Removal of duplicate sorted rows completed in:                                                                                                       00:00:02, leaving 60533 combination rows.
Restore Original order of names in the remaining combinations completed in:                                                                          00:00:00
Wrapping up completed in:                                                                                                                            00:00:06

786240   possible combinations
60533    unique name combinations
60533    printed.

0 combinations were not displayed due to sheet restraints

00:00:54 to process.



Results from newest code:
Rich (BB code):
Create all combinations & remove rows with duplicate name entries in the same row & & remove all combinations with salaries > 60000 completed in:    00:02:06, leaving 531008 combination rows.
Restore Original order of names in the remaining combinations completed in:                                                                          00:00:02
Sort remaining combination rows alphabetically by row completed in:                                                                                  00:01:37
Removal of duplicate sorted rows completed in:                                                                                                       00:00:24, leaving 364253 combination rows.
Restore Original order of names in the remaining combinations completed in:                                                                          00:00:01
Wrapping up completed in:                                                                                                                            00:00:38

3144960  possible combinations
364253   unique name combinations
364253   printed.

0 combinations were not displayed due to sheet restraints

00:04:48 to process.

I haven't done the exact math but that appears to be like about a 350% increase in speed over the code posted in post #122


There are many changes in the newest code that I came up with, I would have to say that the biggest time saver was changing all of the 'replace' sections of code with a version of code that does the 'replacements' to the values in an array as opposed to doing it on the sheet.

Please try the newest code out & let me know what you think. There is still a memory hog in the code that I haven't tracked down yet. So you will have to close excel & reopen it each time you run the code.

VBA Code:
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
Runs super quick Johnny! 🙂

As you said, it appears after macro runs excel sticks around 224MB. Could it just be due to the data? I looked at your code and couldn't find any instance of an array not being cleared and all copy paste methods are set to false after being used. Not a big deal to have to restart if wanting to run it again though! Awesome work 👏
 
Upvote 0
You didn't post your results :(

Also, please update the thread answer to the one you like best. ;)
 
Upvote 0
My bad haha.

Here ya go ;)

Rich (BB code):
Create all combinations & remove rows with duplicate name entries in the same row & & remove all combinations with salaries > 60000 completed in:    00:07:20, leaving 481530 combination rows.
Restore Original order of names in the remaining combinations completed in:                                                                          00:00:13
Sort remaining combination rows alphabetically by row completed in:                                                                                  00:01:37
Removal of duplicate sorted rows completed in:                                                                                                       00:00:15, leaving 341646 combination rows.
Restore Original order of names in the remaining combinations completed in:                                                                          00:00:03
Wrapping up completed in:                                                                                                                            00:00:34

9408000  possible combinations
341646   unique name combinations
341646   printed.

0 combinations were not displayed due to sheet restraints

00:10:02 to process.
 
Upvote 0
WOW !!! The closest I can find to compare to is, from you in post #124 about the code in post #122:
Rich (BB code):
00:33:02 to process.Create all combinations & remove rows with duplicate entries in the same row completed in:    00:03:23, leaving 5723136 combination rows.
Sort remaining combination rows alphabetically by row completed in:                           00:50:15
Removal of duplicate sorted rows completed in:                                                00:05:19, leaving 1386505 combination rows.
Restore Original order of names in the remaining combinations completed in:                   00:00:14
Remove all combinations with salaries > 60000 completed in:                                   00:04:16, leaving 842139 combination rows
Wrapping up completed in:                                                                     00:05:23

9144576  possible combinations
842139   unique name combinations
842139   printed.

0 combinations were not displayed due to sheet restraints

01:08:52 to process.

That equates to 9144576 possible combinations / 4132 seconds = 2,213 combinations/second



What you posted in post #136 about the code in post #134:
Rich (BB code):
Create all combinations & remove rows with duplicate name entries in the same row & & remove all combinations with salaries > 60000 completed in:    00:37:51, leaving 530455 combination rows.
Restore Original order of names in the remaining combinations completed in:                                                                          00:00:20
Sort remaining combination rows alphabetically by row completed in:                                                                                  00:03:06
Removal of duplicate sorted rows completed in:                                                                                                       00:00:19, leaving 377656 combination rows.
Restore Original order of names in the remaining combinations completed in:                                                                          00:00:00
Wrapping up completed in:                                                                                                                            00:03:02

10080000     possible combinations
377656   unique name combinations
377656   printed.

0 combinations were not displayed due to sheet restraints

00:44:38 to process.

That equates to 10080000 possible combinations / 2678 seconds = 3,764 combinations/second


What you posted in post #149 about the code in post #145:
Rich (BB code):
Create all combinations & remove rows with duplicate name entries in the same row & & remove all combinations with salaries > 60000 completed in:    00:07:20, leaving 481530 combination rows.
Restore Original order of names in the remaining combinations completed in:                                                                          00:00:13
Sort remaining combination rows alphabetically by row completed in:                                                                                  00:01:37
Removal of duplicate sorted rows completed in:                                                                                                       00:00:15, leaving 341646 combination rows.
Restore Original order of names in the remaining combinations completed in:                                                                          00:00:03
Wrapping up completed in:                                                                                                                            00:00:34

9408000  possible combinations
341646   unique name combinations
341646   printed.

0 combinations were not displayed due to sheet restraints

00:10:02 to process.

That equates to 9408000 possible combinations / 602 seconds = 15,628 combinations/second ... Over 4x faster than the previous code from post #134 !!! & over 7x faster than the code from post #122 !!!



If we aren't careful, we will get a speeding ticket. ROTFL

I will look into this memory issue previously discussed to see if we can solve that issue.
 
Upvote 0

Forum statistics

Threads
1,213,550
Messages
6,114,265
Members
448,558
Latest member
aivin

We've detected that you are using an adblocker.

We have a great community of people providing Excel help here, but the hosting costs are enormous. You can help keep this site running by allowing ads on MrExcel.com.
Allow Ads at MrExcel

Which adblocker are you using?

Disable AdBlock

Follow these easy steps to disable AdBlock

1)Click on the icon in the browser’s toolbar.
2)Click on the icon in the browser’s toolbar.
2)Click on the "Pause on this site" option.
Go back

Disable AdBlock Plus

Follow these easy steps to disable AdBlock Plus

1)Click on the icon in the browser’s toolbar.
2)Click on the toggle to disable it for "mrexcel.com".
Go back

Disable uBlock Origin

Follow these easy steps to disable uBlock Origin

1)Click on the icon in the browser’s toolbar.
2)Click on the "Power" button.
3)Click on the "Refresh" button.
Go back

Disable uBlock

Follow these easy steps to disable uBlock

1)Click on the icon in the browser’s toolbar.
2)Click on the "Power" button.
3)Click on the "Refresh" button.
Go back
Back
Top