# Help with max rows of a million+



## cspengel (Nov 25, 2022)

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



```
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
```


----------



## johnnyL (Nov 26, 2022)

Can you provide some test data via XL2BB?


----------



## cspengel (Nov 26, 2022)

johnnyL said:


> Can you provide some test data via XL2BB?


Thanks for the reply johnnyL, here is some test data. The code can be slow depending how many combinations. I attached more names than necessary on the "Worksheet" sheet in case you wanted to test more or less. Feel free to remove some names as the current amount would take awhile and result in a "write" error anyways as it exceeds 1million rows. The most combinations I've been able to get to is 1,244,000 as the macro posted already removes some duplicates before it begins to write. If only I can get it to do that for the salary I would be golden. I appreciate you looking at this. 

Sheet name: "Worksheet"

3game.xlsmABCDEFGHI1QBRBRB2WR1WR2WR3TEFLEXDST2Josh AllenSaquon BarkleySaquon BarkleyStefon DiggsDavid Sills VStefon DiggsT.J. HockensonSaquon BarkleyBuffalo Bills3Rhamondre StevensonRhamondre StevensonJustin JeffersonJalen ReagorJustin JeffersonDalton SchultzRhamondre StevensonMinnesota Vikings4Dalvin CookDalvin CookCeeDee LambMarcus JohnsonCeeDee LambDawson KnoxDalvin CookNew York Giants5Tony PollardTony PollardAmon-Ra St. BrownKhalil ShakirAmon-Ra St. BrownHunter HenryTony Pollard6Devin SingletaryKendrick BourneGabe DavisDevin Singletary7Ezekiel ElliottLawrence CagerJakobi MeyersEzekiel Elliott8Jamaal WilliamsNelson AgholorAdam ThielenJamaal Williams9D'Andre SwiftKenny GolladayDarius SlaytonStefon Diggs10Damien HarrisIsaiah HodginsMichael GallupJustin Jefferson11James CookIsaiah McKenzieCeeDee Lamb12Kalif RaymondAmon-Ra St. Brown13Richie James Jr.Gabe Davis14K.J. OsbornJakobi Meyers15Adam ThielenWorksheet

Sheet name: "Salary"

3game.xlsmABCDE1NameSalaryProjectionTEAMColumn12Josh Allen95007.77BUF30.923Justin Jefferson860020.49MIN24.844Amon-Ra St. Brown76001.2NYG23.45Mac Jones65000NYG23.286Kirk Cousins74000MIN22.867Isaiah McKenzie52000.79DAL19.38Stefon Diggs93000DET17.79Jared Goff69000NE17.610Dalton Schultz58000DET17.111Dak Prescott80000BUF16.8412Adam Thielen59000DET16.613Ezekiel Elliott70007.18DAL1614Rhamondre Stevenson720013.92NE15.715Nelson Agholor51000BUF15.516CeeDee Lamb79000DET14.717Daniel Jones75000NE14.5218Hunter Henry49000MIN13.819Saquon Barkley88002.26DAL13.220T.J. Hockenson63005.06NYG12.821Richie James Jr.54000DET12.622Jamaal Williams710023.65BUF10.623DeVante Parker54007.14NE1024Minnesota Vikings40000DAL925Michael Gallup57004.09DET8.826DJ Chark Jr.500017.56BUF8.627Devin Singletary69000NYG8.528D'Andre Swift620011.65BUF8.329Darius Slayton64000DAL7.830Jakobi Meyers67000DET7.731Dalvin Cook78001.21MIN7.632Jake Ferguson44000NYG7.233Tony Pollard850012.75DAL7.134Peyton Hendershot43000DAL6.235Buffalo Bills44005.95DET636Kene Nwangwu47000MIN637Gary Brightwell46000.31NYG5.938Gabe Davis720013.17BUF5.839Kalif Raymond550018.86DAL5.540Detroit Lions32003.2NE541Isaiah Hodgins51007.66MIN4.642Kendrick Bourne490015.04DET4.443Dallas Cowboys50000DAL444New York Giants35002.79NYG345Jalen Reagor47001.36DET346New England Patriots42000DET347Johnny Mundt43000BUF348Chris Myarick420016.2MIN2.849James Cook55000DET2.850Dawson Knox55003.91NYG2.751James Mitchell42000NE2.752Lawrence Cager480015.69NYG2.553Justin Jackson52000NYG2.454Matt Breida51007.95DAL255K.J. Osborn53000MIN1.856Brock Wright460015.81DET1.657Damien Harris64000NE1.658Tanner Hudson43000DAL1.559Alexander Mattison50003.61MIN1.160Quintin Morris42007.18DAL0.861Nyheim Hines49008.71NE0.362Kenny Golladay530015.72MIN063Nick Mullens610014.62DAL064Nick Ralston400014.31NYG065Jeremiah Hall450014NE066Matt Barkley600011.81DAL067Pierre Strong Jr.450011.7DET068Sean McKeon410011.56DET069Garrett Griffin400010.13MIN070Hunter Thedford400010.11NYG071Thomas Hennigan45008.63BUF072Dennis Houston45008.34NE073Josh Hammond45007.24NE074Jonnu Smith47007.11BUF075Tre Nixon45006.53DET076Travis Toivonen45006.18NYG077T.J. Vasher45006.01MIN078Marcus Johnson47005.91NYG079Tyrod Taylor61005.84DAL080Duke Johnson45005.64MIN081Nick Muse40005.58BUF082Stanley Berryhill45005.57NE083Bailey Zappe61004.78DET084Jason Cabinda45004.51NE085Matt Sokol40004.3BUF086Josh Johnson45004.14DET087Brian Hoyer60003.73DET088Isaiah Coulter45003.3NE089Khalil Shakir46003.26BUF090David Sills V46003.23DAL091Brian Lewerke60002.98NYG092Sandro Platzgummer45002.59DAL093Lil'Jordan Humphrey46002.45DET094Tyquan Thornton53002.11NE095Antonio Callaway45002.09NYG096Qadree Ollison46001.95NYG097Jameson Williams45001.86DET098Ryan Nall45001.46NYG099Tanner Gentry45001.41MIN0100KaVontae Turpin46001.4BUF0101C.J. Ham45000.94MIN0102Nate Sudfeld60000.91MIN0103Jake Kumerow45000.82DAL0104Taiwan Jones45000.53BUF0105Collin Johnson45000.35NE0Salary


----------



## johnnyL (Nov 26, 2022)

Your code is making my head hurt while trying to look through it.

You have probably figured out how to make it take as long as possible to run. 

One thing I noticed is you are using the Status bar:

```
If lIterationCount / 1000 = lIterationCount \ 1000 Then Application.StatusBar = lIterationCount & " / " & lLastIteration
```

You are doing two calculations each time that line is executed & when the condition is met, you update the Status bar. Updating the Status bar is a performance hit.

I would suggest updating the Status bar less frequently and do less calculations.
example:

```
If lIterationCount Mod 10000 = 0 Then Application.StatusBar = lIterationCount & " / " & lLastIteration
```

That does one calculation each time the line is executed & only updates the status bar about every 8 - 10 seconds because instead of updating every 1000, it updates every 10000. You can adjust that number as you see fit.


Other than that, If you could explain exactly what the script does, it could probably be rewritten to run in less than a minute or two.
You don't have to explain every line of code, just explain what the general purpose of each section is doing for you,


----------



## cspengel (Nov 26, 2022)

johnnyL said:


> Your code is making my head hurt while trying to look through it.
> 
> You have probably figured out how to make it take as long as possible to run.
> 
> ...


Yeah...It's Pretty Slow. I don't know much of anything and basically just trying to understand it myself, copy and paste, edit what I need. I've spent so much time on it and getting really no where. It takes hours to get the data I need. Once it's retrieved it helps a lot with what I am using it for, but the time it takes is exhausting. 

First section takes the names entered on the "Worksheet" sheet and checks to see if they have a salary listed on the "Salary" sheet. If the name is not on the Salary sheet, it ends Sub. If the name is on the salary sheet and there is a corresponding salary, a pop up box will appear letting you know how many combinations to expect. 


```
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
```

Second section clears anything that is to the right of the names to prepare for the "writing" process. It transfers over the headers and begins checking for combinations. A column is added to header called "ComboID" which is used to check for some type of duplicates. Scripting Dictionary is used to compare text in the same row and If there is a duplicate it will not write the combination.  If there is no duplicate, it will write to the sheet. 


```
'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
```

3rd section deals with checking to see what name was used last in the combination...Or at least that's what I think it does.


```
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
```

Fourth section is where the helper columns are added. This happens after all the combinations are "written". Keep in mind what is "written" does not show on the sheet as it is happening because EnableEvents is turned off. The helper columns are basically copies of the "written" names 3 separate times. For (Salary, Projection, and Team)


```
'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
```

5th section takes the first copy of names (that happened in the 4th section) and replaces the names with the players salary. It then adds up the players salary and calculates that in a new column.
After all the salaries are calculated, all of the salaries that are over 60000 are filtered and then deleted by range. This part takes AWHILE!!! (It would be quicker to filter the salaries and maybe change the value to 1 if all are over 60k and then un filter. Then sort by 1 and delete, but I am not sure how to do that. ) 


```
'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
```

6th section sorts the original written rows by name and removes any duplicates rows.


```
'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
```

 7th Section deals with replacing the remainder of the copied names in the helper columns. This is for projection, and team. The helper columns for projection are then added together and calculated in a new column. As for the team helper columns. That is used to determine which team is used the most in each row, and then to determine which team is used 2nd most. Those are then written in a new column.


```
'''''''''''''''''''''''''''''''''''''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
```

8th section really isn't used. Basically there if I wanted to maybe add a button and filter the combinations by players. I would then enter two names I want to filter the data by and it would put a "1" under the filter column. I would then manually filter by 1 or 0. This was added because I couldn't filter players ACROSS rows. 

```
'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
```


Last section removes helper columns, pops up a dialog box saying time it took, how many duplicates removed, how many unique. The combinations are then printed to the sheet.


```
'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
```


If your still with me after all that..I salute you. I know it's a mess. I'm Sorry !


----------



## johnnyL (Nov 26, 2022)

Here is the first couple of explanations you gave:

First section takes the names entered on the "Worksheet" sheet and checks to see if they have a salary listed on the "Salary" sheet. If the name is not on the Salary sheet, it ends Sub. If the name is on the salary sheet and there is a corresponding salary, a pop up box will appear letting you know how many combinations to expect.

Second section clears anything that is to the right of the names to prepare for the "writing" process. It transfers over the headers and begins checking for combinations. A column is added to header called "ComboID" which is used to check for some type of duplicates. Scripting Dictionary is used to compare text in the same row and If there is a duplicate it will not write the combination. If there is no duplicate, it will write to the sheet.I



The following is more specific & what I would like to see from you, as an example:
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.

2) Clear all columns to the right of Column I on the "Worksheet" sheet. Copy headers from A1:I1 on the "Worksheet" sheet to K1:S1 on the "Worksheet" sheet. Add header "ComboID" to T1 on the "Worksheet" sheet. Create the combinations & if there are no duplicate names in the same combination row then write the combination to K row#:S row# on the "Worksheet" sheet & write lIterationCount to T row# on the "Worksheet" sheet.



Let me know if either of my interpretations are incorrect and continue on with the more specific explanations.


Can we delete the duplicates from either or both of the sheets prior to doing the combination calculations? If so, are we removing duplicate names? Would it matter what column the name was originally listed in on the "Worksheet" sheet, or what row the name is listed on the "Salary" sheet?


----------



## cspengel (Nov 27, 2022)

johnnyL said:


> Here is the first couple of explanations you gave:
> 
> First section takes the names entered on the "Worksheet" sheet and checks to see if they have a salary listed on the "Salary" sheet. If the name is not on the Salary sheet, it ends Sub. If the name is on the salary sheet and there is a corresponding salary, a pop up box will appear letting you know how many combinations to expect.
> 
> ...


I'll try and be more specific in following post. As for your last question, there isn't any duplications to remove prior to combinations being generated. Some names may repeat throughout columns in A:I on the "Worksheet" sheet because if that player is not in another column, then combinations of him and another player may not happen. It basically does combinations in order of column. So A to B to C to D etc.. atleast that is my interpretation of it. It's kind of confusing to explain, or atleast for me, but I use certain players more as I want them in more positions. The columns are basically fixed to the players listed in that column. So when combinations are generated, only the players in those columns will be chosen for what the header is.


----------



## johnnyL (Nov 27, 2022)

Ok, I will await your next clarification post.


----------



## cspengel (Nov 27, 2022)

The following is more specific & what I would like to see from you, as an example:
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.

2) Clear all columns to the right of Column I on the "Worksheet" sheet. Copy headers from A1:I1 on the "Worksheet" sheet to K1:S1 on the "Worksheet" sheet. Add header "ComboID" to T1 on the "Worksheet" sheet. Create the combinations & if there are no duplicate names in the same combination row then write the combination to K row#:S row# on the "Worksheet" sheet & write lIterationCount to T row# on the "Worksheet" sheet.

3) Checks last name used in column A:I  to determine increment


```
'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
```

4) Copies name combinations from columns K:S and pastes them in columns U:AC, AD:AL, AM:AU 

```
'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
```

5) Replaces copied names in column U:AC with the players respective salary data on "Salary" sheet. Column AV becomes "Salary" column and the sum of columns U:AC is calculated. Max salary is declared at 60000. The data in A2:I26 is copied to the "Salary" sheet in cell G2:O26 before filter is applied. Autofilter is then applied to the range AV. If the value in AV is greater than 60000, the range K:BE for that row will be deleted. The data copied to G2:O26 is then cut and pasted back to A2:I26 and autofilter is turned off.


```
'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
```

More coming..


----------



## cspengel (Nov 27, 2022)

cspengel said:


> The following is more specific & what I would like to see from you, as an example:
> 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.
> 
> 2) Clear all columns to the right of Column I on the "Worksheet" sheet. Copy headers from A1:I1 on the "Worksheet" sheet to K1:S1 on the "Worksheet" sheet. Add header "ComboID" to T1 on the "Worksheet" sheet. Create the combinations & if there are no duplicate names in the same combination row then write the combination to K row#:S row# on the "Worksheet" sheet & write lIterationCount to T row# on the "Worksheet" sheet.
> ...


6) An array is built from the combination names in columns K:S. States it excludes iteration # column. I am not sure what that is referencing.  May be the ComboID in column T. The duplicate combinations are then removed. Keep in mind Duplicates in ANY order are removed. If the same players are used in a lineup, regardless of column, they are removed.


```
'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
```

7) The names copied over to AD:AL are replaced with the corresponding players projection on the "Salary" sheet. The names copied over to AM:AU are replaced with the corresponding players team located on the "Salary" Sheet. 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.


```
'''''''''''''''''''''''''''''''''''''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
```

8) "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.


```
'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
```

9) 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.

That is all I think... Ha. Thanks for bearing with me.

```
'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
```


----------



## cspengel (Nov 25, 2022)

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



```
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
```


----------



## cspengel (Nov 28, 2022)

After removing sections 1 by 1 to test for speed, it is the "REPLACE" function that is adding most of the time. Just writing the combinations and removing names that are in the same row took 58 seconds for 82000 combos. When replacing names with salary, it added a minute and 20 seconds. When replacing all names with corresponding projection, salary, and team(for helper columns), it added over 3 minutes. So when I actually do the amount of combos I want.. It it close to an hour or more. Not sure how to make replace function quicker though.


----------



## cspengel (Nov 28, 2022)

After removing all the names from the "Salary" Sheet that are not used on the "Worksheet" sheet, I can run 1,244,000 combinations in 16 min. A definite improvement from the hour and 10 it was originally. Now if I can find a way to maybe print the data as it is closing in on the max rows allowed, and then begin generating the rest of combinations from where it left off..


----------



## johnnyL (Nov 29, 2022)

I can't get your script to run in its entirety for some reason. It always seems to crash & restart the script somewhere in the 'Sorting'.

I noticed that you are reading/writing to the sheet many times which will slow the speed of the script, so I am going to offer some changes that you can try:

1) Change:

```
ReDim aryNames(1 To 2, 1 To lLastColumn)    '1 holds the in-use entry row
```

to:

```
Dim WorksheetArray      As Variant
'
' Save Worksheet data into 2D 1 based WorksheetArray
    WorksheetArray = wksData.Range("A2:" & Split(Cells(1, lLastColumn).Address, "$")(1) & wksData.Range("A1").CurrentRegion.Find("*", , xlFormulas, , xlByRows, xlPrevious).Row)
'
    ReDim aryNames(1 To 2, 1 To lLastColumn)    '1 holds the in-use entry row
```

then change:

```
'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
```

to:

```
'Load names into scripting dictionary
        For lColumnIndex = lLastColumn To 1 Step -1
''            sName = Cells(aryNames(1, lColumnIndex), lColumnIndex).Value
            sName = WorksheetArray(aryNames(1, lColumnIndex) - 1, lColumnIndex)  'I2,H2...A2 I3,H2...A2 I4,H2...A2 I2,H3,G2...A2
            oSD.Item(sName) = oSD.Item(sName) + 1
        NextI
```

Try that and see if your script still runs correctly. I have more changes to offer, but I want to make sure that works,

Edit: Those changes should allow you to read the original data from an array instead from the sheet.


----------



## cspengel (Nov 29, 2022)

johnnyL said:


> I can't get your script to run in its entirety for some reason. It always seems to crash & restart the script somewhere in the 'Sorting'.
> 
> I noticed that you are reading/writing to the sheet many times which will slow the speed of the script, so I am going to offer some changes that you can try:
> 
> ...


Sorry that it's not working for you 😕. Not sure why that would be. I could maybe attach what I currently have done and see if that makes a difference.

 Thanks for the new suggestions! I am running what you suggested so I should know in about 10 minutes.


----------



## johnnyL (Nov 29, 2022)

I am not concerned if it works for me, I am more concerned if it works for you,


----------



## cspengel (Nov 29, 2022)

johnnyL said:


> I am not concerned if it works for me, I am more concerned if it works for you,


Everything works correctly with the code you provided. (no change in time, but macro runs)


----------



## johnnyL (Nov 29, 2022)

Sweet!

Next change:

```
' Save Worksheet data into 2D 1 based WorksheetArray
    WorksheetArray = wksData.Range("A2:" & Split(Cells(1, lLastColumn).Address, "$")(1) & wksData.Range("A1").CurrentRegion.Find("*", , xlFormulas, , xlByRows, xlPrevious).Row)
```

to:

```
' Save Worksheet data into 2D 1 based WorksheetArray
    WorksheetArray = wksData.Range("A2:" & Split(Cells(1, lLastColumn).Address, "$")(1) & wksData.Range("A1").CurrentRegion.Find("*", , xlFormulas, , xlByRows, xlPrevious).Row)
'
    ReDim NoDupeRowArray(1 To lLastIteration, 1 To lLastColumn + 1)
```

then change:

```
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
```

to:

```
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))               '  ... This variable is never used so it is not needed
''                Cells(lWriteRow, lRefColumn + lColumnIndex).Value = Cells(aryNames(1, lColumnIndex), lColumnIndex).Value
                NoDupeRowArray(lWriteRow - 1, lRefColumn + lColumnIndex - lLastColumn - 1) = WorksheetArray(aryNames(1, lColumnIndex) - 1, lColumnIndex)
            Next
          
            'Uncomment next row to see the lIterationCount for the printed row
''            Cells(lWriteRow, lLastWriteColumn + 1).Value = lIterationCount
            NoDupeRowArray(lWriteRow - 1, lLastColumn + 1) = lIterationCount
```

then change:

```
Application.StatusBar = "Sorting"
    Application.ScreenUpdating = False
```

to:

```
wksData.Cells(2, lWriteColumn - 1).Resize(UBound(NoDupeRowArray, 1), UBound(NoDupeRowArray, 2)) = NoDupeRowArray
'
    Application.StatusBar = "Sorting"
    Application.ScreenUpdating = False
```

That should do all of the writes from K2 to Tx all at once instead of each cell one at at a time by writing all results to NoDupeRowArray & then when finished it will write all results to the sheet.

Let me know if that works.


----------



## cspengel (Nov 29, 2022)

johnnyL said:


> Sweet!
> 
> Next change:
> 
> ...


Thanks for all that! I'm getting Subscript out of range on this:

```
ReDim NoDupeRowArray(1 To lLastIteration, 1 To lLastColumn + 1)
```

I declared NoDupeRowArray as Variant.

When I hover over lLastIteration it is showing it is 0. When I hover over lLastColumn, it shows 7.


----------



## johnnyL (Nov 29, 2022)

You should dim it as follows:

Dim NoDupeRowArray()    As Variant

If you still get subscript out of range error, hover your mouse over each variable in the error line and see which one reports the error.


----------



## cspengel (Nov 29, 2022)

johnnyL said:


> You should dim it as follows:
> 
> Dim NoDupeRowArray()    As Variant
> 
> If you still get subscript out of range error, hover your mouse over each variable in the error line and see which one reports the error.


I Dim as you said. I am not showing an error on any variable in the line it reports an error


----------



## cspengel (Nov 25, 2022)

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



```
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
```


----------



## cspengel (Nov 29, 2022)

If I put my cursor on anything with "aryNames" (Doesn't matter which line of code, just anything that has aryNames, It shows <TypeMismatch>. Not sure if that is anything.

If I put my cursor over NoDupeRowArray further down the sheet I get subscript out of range on second attached image.

I am assuming it is lLastIteration. lLastIteration isn't declared prior to anything before. What is it supposed to be?


----------



## johnnyL (Nov 29, 2022)

If you want to, upload your current workbook somewhere, and then provide a link to it. I will take a look at it after I get some sleep.


----------



## cspengel (Nov 29, 2022)

Will do. Thank for your help. Goodnight!


----------



## johnnyL (Nov 29, 2022)

cspengel said:


> I am assuming it is lLastIteration. lLastIteration isn't declared prior to anything before. What is it supposed to be?
> View attachment 79801


My instructions were not correct and as a result you don't have the code in the proper place. 

The proper place for those top two lines you are showing is in the following section:

```
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
'
' Save Worksheet data into 2D 1 based WorksheetArray
    WorksheetArray = wksData.Range("A2:" & Split(Cells(1, lLastColumn).Address, "$")(1) & wksData.Range("A1").CurrentRegion.Find("*", , xlFormulas, , xlByRows, xlPrevious).Row)
'
    ReDim NoDupeRowArray(1 To lLastIteration, 1 To lLastColumn + 1)
'
    Cells(1, lLastWriteColumn + 1).Value = "ComboID"
```

Sorry about that.


----------



## cspengel (Nov 29, 2022)

johnnyL said:


> My instructions were not correct and as a result you don't have the code in the proper place.
> 
> The proper place for those top two lines you are showing is in the following section:
> 
> ...


Thanks for that!
After running some tests with the code I posted vs yours, yours runs 3min & 30 seconds faster! To run 967,680 combos, yours took 9min 11 seconds and the code I posted took 12min 41 seconds.

One thing I noticed however, is that without your code, I can run combinations of 1,128,960 (alittle over max rows as the duplicate rows are removed).
With your code, I get a subscript out of range when attempting to run the same. I assume that has to do with the array. Regardless I am happy that your code runs quicker.

Do you perhaps see any path forward into somehow doing like a midway check and removing what was already "written" for what doesn't meet that salary cap so I can get more combinations ran?

Basically out of the 967,680 combinations ran. Only 1,380 combos were printed, but the written to array or whatnot still overcaps the max allowed. Only thing I can think of is to have another array made that takes what the added salary is for that row, and after a certain iteration remove what is over salary range from the current written array. I'm not even sure if that's possible. Regardless, I appreciate the help you have provided and certainly happy with the results!

Here is the current code with your code include:

```
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 WorksheetArray      As Variant
    Dim NoDupeRowArray()    As Variant
   
    Dim wksData As Worksheet
    Dim lngLastRow 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 lLastHTeamCol 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 B containing each name in the name/column layout worksheet " & _
            "and column C containing 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("B2:B" & .Cells(Rows.Count, 2).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
'
' Save Worksheet data into 2D 1 based WorksheetArray
    WorksheetArray = wksData.Range("A2:" & Split(Cells(1, lLastColumn).Address, "$")(1) & wksData.Range("A1").CurrentRegion.Find("*", , xlFormulas, , xlByRows, xlPrevious).Row)
'
    ReDim NoDupeRowArray(1 To lLastIteration, 1 To lLastColumn + 1)
'
    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
        
        '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
            sName = WorksheetArray(aryNames(1, lColumnIndex) - 1, lColumnIndex)  'I2,H2...A2 I3,H2...A2 I4,H2...A2 I2,H3,G2...A2
            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))               '  ... This variable is never used so it is not needed
''                Cells(lWriteRow, lRefColumn + lColumnIndex).Value = Cells(aryNames(1, lColumnIndex), lColumnIndex).Value
                NoDupeRowArray(lWriteRow - 1, lRefColumn + lColumnIndex - lLastColumn - 1) = WorksheetArray(aryNames(1, lColumnIndex) - 1, lColumnIndex)
            Next
         
            'Uncomment next row to see the lIterationCount for the printed row
''            Cells(lWriteRow, lLastWriteColumn + 1).Value = lIterationCount
            NoDupeRowArray(lWriteRow - 1, lLastColumn + 1) = 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
   
     wksData.Cells(2, lWriteColumn - 1).Resize(UBound(NoDupeRowArray, 1), UBound(NoDupeRowArray, 2)) = NoDupeRowArray
'
    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, 2).Value, _
            Replacement:=Worksheets("Salary").Cells(lRowIndex, 3).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
   
        With Range("AV2", Range("AV" & Rows.Count).End(xlUp))
        .Value = Evaluate(Replace("if(@>60000,0,if(@="""","""",@))", "@", .Address))
        .Value = Evaluate(Replace("if(@<58000,1,if(@="""","""",@))", "@", .Address))
        End With
       
        ActiveWorkbook.Worksheets("Worksheet").Sort.SortFields.Clear
    ActiveWorkbook.Worksheets("Worksheet").Sort.SortFields.Add2 Key:=Range( _
        "AV2:AV" & lLastRow), SortOn:=xlSortOnValues, Order:=xlAscending, DataOption:= _
        xlSortNormal
       
         With ActiveWorkbook.Worksheets("Worksheet").Sort
        .SetRange Range("K2:BE" & lLastRow)
        .Header = xlGuess
        .MatchCase = False
        .Orientation = xlTopToBottom
        .SortMethod = xlPinYin
        .Apply
    End With
    With wksData
        .Range("A2:I26").Cut names.Range("G2")
        Application.CutCopyMode = False
      End With
   
    ActiveSheet.Range("K1:AV" & lLastRow).AutoFilter Field:=38, Criteria1:=Array("0", "1")
    Range("K2:AV" & lLastRow).Select
    Application.DisplayAlerts = False
    Selection.Delete
    ActiveSheet.Range("A1").Select
    ActiveSheet.Range("K1:AV" & lLastRow).AutoFilter Field:=38
       With names
    .Range("G2:O26").Cut wksData.Range("A2")
    Application.CutCopyMode = False
    End With
If ActiveSheet.AutoFilterMode Then
ActiveSheet.AutoFilterMode = False
End If

'----------------------------------------------------------------------------------


 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, 2).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
         ActiveSheet.Range("$K$1:$AX$1048576").RemoveDuplicates Columns:=39, Header:= _
        xlYes
    End With
    ''Add Value Column
    Cells(1, lLastHTeamCol + 3).Value = ChrW(931) & " Value"
    With Range(Cells(2, lLastHTeamCol + 3), Cells(lLastRowDeDuped, lLastHTeamCol + 3))
        .Formula2R1C1 = "=(RC[-1]/RC[-2])*1000"
        Application.Calculate
        .Value = .Value
     End With
    
       With Range("AX2", Range("AX" & Rows.Count).End(xlUp))
        .Value = Evaluate(Replace("if(@<1.65,0,if(@="""","""",@))", "@", .Address))
        End With
       
        ActiveWorkbook.Worksheets("Worksheet").Sort.SortFields.Clear
    ActiveWorkbook.Worksheets("Worksheet").Sort.SortFields.Add2 Key:=Range( _
        "AX2:AX" & lLastRow), SortOn:=xlSortOnValues, Order:=xlAscending, DataOption:= _
        xlSortNormal
       
         With ActiveWorkbook.Worksheets("Worksheet").Sort
        .SetRange Range("K2:BE" & lLastRow)
        .Header = xlGuess
        .MatchCase = False
        .Orientation = xlTopToBottom
        .SortMethod = xlPinYin
        .Apply
    End With
    With wksData
        .Range("A2:I26").Cut names.Range("G2")
        Application.CutCopyMode = False
      End With
    ActiveSheet.Range("K1:AX" & lLastRow).AutoFilter Field:=40, Criteria1:="0"
    Range("K2:AX" & lLastRow).Select
    Application.DisplayAlerts = False
    Selection.Delete
    ActiveSheet.Range("A1").Select
    ActiveSheet.Range("K1:AX" & lLastRow).AutoFilter Field:=40
       With names
    .Range("G2:O26").Cut wksData.Range("A2")
    Application.CutCopyMode = False
    End With
    If ActiveSheet.AutoFilterMode Then
ActiveSheet.AutoFilterMode = False
End If

  '''''''''''''''''''''''''''''''''''''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, 2).Value, _
            Replacement:=Worksheets("Salary").Cells(lRowIndex2, 5).Value, LookAt:=xlWhole, _
            SearchOrder:=xlByRows, MatchCase:=False, SearchFormat:=False, _
            ReplaceFormat:=False
    Next '''''''''''''''''''''''''''
  
    ''Add Team Stack Column
    Cells(1, lLastHTeamCol + 4).Value = ChrW(931) & " Stack"
    With Range(Cells(2, lLastHTeamCol + 4), Cells(lLastRowDeDuped, lLastHTeamCol + 4))
        .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 + 5).Value = ChrW(931) & " Stack POS"
    With Range(Cells(2, lLastHTeamCol + 5), Cells(lLastRowDeDuped, lLastHTeamCol + 5))
   
    .Formula2R1C1 = "=TEXTJOIN("","",1,IF(RC[-13]:RC[-4]=RC[-1],R1C[-13]:R1C[-4],""""))"
        Application.Calculate
        .Value = .Value
    End With
   
    ''Add 2nd Team Stack Column
    Cells(1, lLastHTeamCol + 6).Value = ChrW(931) & " Stack2"
    With Range(Cells(2, lLastHTeamCol + 6), Cells(lLastRowDeDuped, lLastHTeamCol + 6))
        .Formula2R1C1 = "=IFERROR(INDEX(RC[-14]:RC[-5],MODE(IF((RC[-14]:RC[-5]<>"""")*(RC[-14]:RC[-5]<>INDEX(RC[-14]:RC[-5],MODE(IF(RC[-14]:RC[-5]<>"""",MATCH(RC[-14]:RC[-5],RC[-14]:RC[-5],0))))),MATCH(RC[-14]:RC[-5],RC[-14]:RC[-5],0)))),"""")"
        Application.Calculate
        .Value = .Value
    End With
   
    ''Add 2nd Team Stack Pos
    Cells(1, lLastHTeamCol + 7).Value = ChrW(931) & " Stack2 POS"
    With Range(Cells(2, lLastHTeamCol + 7), Cells(lLastRowDeDuped, lLastHTeamCol + 7))
   
    .Formula2R1C1 = "=TEXTJOIN("","",1,IF(RC[-14]:RC[-4]=RC[-1],R1C[-14]:R1C[-4],""""))"
        Application.Calculate
        .Value = .Value
    End With
   
    'Filter 0-1
    Cells(1, lLastHTeamCol + 8).Value = ChrW(931) & " Filter"
    With Range(Cells(2, lLastHTeamCol + 8), Cells(lLastRowDeDuped, lLastHTeamCol + 8))
   
    End With
   
    'Player 1 Filter
    Cells(1, lLastHTeamCol + 9).Value = ChrW(931) & " Player1"
    With Range(Cells(2, lLastHTeamCol + 9), Cells(lLastRowDeDuped, lLastHTeamCol + 9))
   
    End With
   
    'Player 2 Filter
    Cells(1, lLastHTeamCol + 10).Value = ChrW(931) & " Player2"
    With Range(Cells(2, lLastHTeamCol + 10), Cells(lLastRowDeDuped, lLastHTeamCol + 10))
   
    End With
   
    'Sort each row
   
    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 ?????
   
  
   
    'Remove Salary Columns
    Range(Cells(2, lFirstHSortColumn), Cells(lLastRowDeDuped, lLastHTeamCol)).EntireColumn.Delete

   
   
    sOutput = lLastIteration & vbTab & " possible combinations" & vbLf & _
        Format(Now() - dteStart, "hh:mm:ss") & " to process."
   
    ActiveSheet.UsedRange.Columns.AutoFit
    MsgBox sOutput, , "Output Report"
    Debug.Print sOutput
        Call OptimizeCode_End
    Application.StatusBar = False
End_Sub:
   
   
End Sub
```


----------



## johnnyL (Nov 29, 2022)

I see you have made some changes to the original code so I will have to see what your changes do.

Is the most recent code you posted the best that you have come up with as far as combining my suggestions with what you have come up with to produce the fastest results?

We will get to the # of results allowed after the script is running as fast as we can make it, That shouldn't be a major problem. We can always check the # of results in an array and if it reaches a certain amount, spit out the results & reset the array for more results to spit out later.

I am curious which code to look at at this point, is it the most recent code you posted or the original code with my suggestions? Please explain any potential problems with either approach.


----------



## cspengel (Nov 29, 2022)

"Is the most recent code you posted the best that you have come up with as far as combining my suggestions with what you have come up with to produce the fastest results?"

Yes, the most recent code is what I have come up with your suggestions included. There are a few things changed.

-The status bar count was removed
-A Value calculation was added after the projection column(therefore all columns after shift one more to the right), which is the projection total/salary total * 1000
-After the total salary is calculated, Salaries over 60000 are replaced with 0 and salaries under 58000 are replaced with 0. Salary is then sorted smallest to largest, then filtered to 0 and deleted.
-After the value calculation is calculated, values less than 1.65 are replaced with 0, and then sorted smallest to largest. Then column is filtered to 0 and deleted.
-Sorting the combination names and deleting duplicates becomes the very last task. I assumed in doing it last would eliminate the amount of rows needing to be sorted as most of everything else has been deleted.


----------



## johnnyL (Dec 1, 2022)

Again, your most recent code does not work for me, so I will continue plugging away with the previous version.

After some sleep, I will tackle the 'Salary' sheet & reduce that down to only the names in the worksheet.


----------



## cspengel (Dec 1, 2022)

With the most recent code, the names need to be in column B on the salary sheet, salary in column C, projection in column D, and team in column E. I didn't attach the new salary sheet as it may cause confusion. I was using unique and vstack to pull names from the Worksheet. However the macro can't read names that are spilled, so I then have the same names listed both in Column A and B. With column A using the unique function and B pulling the names from col A.. regardless none of that is necessary as long as the names are in column B. I'm not sure why the code isn't working for you though. I'll reattach some test data just incase you want to try again tomorrow. Thanks for the reply.


----------



## cspengel (Dec 1, 2022)

I had an error in the last code I posted, so if you try again to run it, use all this information including the code. It takes approx.. 3 min 58 seconds to run what is in the xl2bb. (Don't minimize or anything while processing). Keep in mind DoEvents is off, so you won't see anything until it is completed. 

I added just a couple more things, which is just another helper column that goes to column BA. It counts the amount of commas in column AZ cells to determine how many players are on a team. It then deletes all rows with more than 4 players per team. The helper column is then deleted.  
- 2 more filters were added that remove rows if two running backs (RB's) are on the same team. This checks the Stack Pos column and Stack2 Pos Column.

Thanks for your help!

mrexcel-testnew.xlsmABCDEFGHI1QBRB1RB2WR1WR2WR3TEFLEXDST2Jalen HurtsJonathan TaylorJonathan TaylorA.J. BrownSamori ToureA.J. BrownPat FreiermuthJonathan TaylorIndianapolis Colts3Najee HarrisNajee HarrisMichael Pittman Jr.Ashton DulinMichael Pittman Jr.Robert TonyanNajee Harris4Aaron JonesAaron JonesDeVonta SmithSammy WatkinsDeVonta SmithJack StollAaron Jones5Miles SandersMiles SandersAllen LazardZach PascalAllen LazardMo Alie-CoxMiles Sanders6AJ DillonSteven Sims Jr.Diontae JohnsonAJ Dillon7Deon JacksonQuez WatkinsGeorge PickensDeVonta Smith8Kenneth GainwellRandall CobbZach PascalAllen Lazard9Boston ScottAlec PierceSammy WatkinsChristian Watson10Benny Snell Jr.Christian WatsonAshton Dulin11Parris CampbellWorksheet

mrexcel-testnew.xlsmABCDE1NameSalaryProjectionTeam2A.J. Brown830015.12PHI3Aaron Jones740014.78GB4AJ Dillon59006.63GB5Alec Pierce55005.22IND6Allen Lazard630010.61GB7Ashton Dulin45001.69IND8Benny Snell Jr.46002.56PIT9Boston Scott51002.36PHI10Christian Watson65009.93GB11Deon Jackson51004.42IND12DeVonta Smith67009.98PHI13Diontae Johnson61007.87PIT14George Pickens660010.65PIT15Indianapolis Colts40006.2IND16Jack Stoll44002.18PHI17Jalen Hurts880021.88PHI18Jonathan Taylor880014.52IND19Kenneth Gainwell52002.34PHI20Michael Pittman Jr.70009.71IND21Miles Sanders700011.52PHI22Mo Alie-Cox45002.62IND23Najee Harris720011.39PIT24Parris Campbell60008.39IND25Pat Freiermuth58009.35PIT26Quez Watkins55005.58PHI27Randall Cobb53007.35GB28Robert Tonyan49005.23GB29Sammy Watkins50005.47GB30Samori Toure47001.48GB31Steven Sims Jr.50002.99PIT32Zach Pascal52002PHISalary


```
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 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 WorksheetArray      As Variant
    Dim NoDupeRowArray()    As Variant
    Dim n As Long
    
    Dim wksData As Worksheet
    Dim rngDataBlock As Range
    Dim lngLastRow As Long, lngLastCol As Long
    Dim rngToDelete As Range

    
    
    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 lLastHTeamCol 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 B containing each name in the name/column layout worksheet " & _
            "and column C containing 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("B2:B32")
            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
'
' Save Worksheet data into 2D 1 based WorksheetArray
    WorksheetArray = wksData.Range("A2:" & Split(Cells(1, lLastColumn).Address, "$")(1) & wksData.Range("A1").CurrentRegion.Find("*", , xlFormulas, , xlByRows, xlPrevious).Row)
'
    ReDim NoDupeRowArray(1 To lLastIteration, 1 To lLastColumn + 1)
'
    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
         
        '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
            sName = WorksheetArray(aryNames(1, lColumnIndex) - 1, lColumnIndex)  'I2,H2...A2 I3,H2...A2 I4,H2...A2 I2,H3,G2...A2
            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
                NoDupeRowArray(lWriteRow - 1, lRefColumn + lColumnIndex - lLastColumn - 1) = WorksheetArray(aryNames(1, lColumnIndex) - 1, lColumnIndex)
            Next
          
            'Uncomment next row to see the lIterationCount for the printed row
            NoDupeRowArray(lWriteRow - 1, lLastColumn + 1) = 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
    
     wksData.Cells(2, lWriteColumn - 1).Resize(UBound(NoDupeRowArray, 1), UBound(NoDupeRowArray, 2)) = NoDupeRowArray
'
    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, "B").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, 2).Value, _
            Replacement:=Worksheets("Salary").Cells(lRowIndex, 3).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
    
        With Range("AV2", Range("AV" & Rows.Count).End(xlUp))
        .Value = Evaluate(Replace("if(@>60000,0,if(@="""","""",@))", "@", .Address))
        .Value = Evaluate(Replace("if(@<58000,1,if(@="""","""",@))", "@", .Address))
        End With
        
        ActiveWorkbook.Worksheets("Worksheet").Sort.SortFields.Clear
    ActiveWorkbook.Worksheets("Worksheet").Sort.SortFields.Add2 Key:=Range( _
        "AV2:AV" & lLastRow), SortOn:=xlSortOnValues, Order:=xlAscending, DataOption:= _
        xlSortNormal
        
         With ActiveWorkbook.Worksheets("Worksheet").Sort
        .SetRange Range("K2:BE" & lLastRow)
        .Header = xlGuess
        .MatchCase = False
        .Orientation = xlTopToBottom
        .SortMethod = xlPinYin
        .Apply
    End With
    With wksData
        .Range("A2:I26").Cut names.Range("G2")
        Application.CutCopyMode = False
      End With
    
    ActiveSheet.Range("K1:AV" & lLastRow).AutoFilter Field:=38, Criteria1:=Array("0", "1")
    Range("K2:AV" & lLastRow).Select
    Application.DisplayAlerts = False
    Selection.Delete
    ActiveSheet.Range("A1").Select
    ActiveSheet.Range("K1:AV" & lLastRow).AutoFilter Field:=38
       With names
    .Range("G2:O26").Cut wksData.Range("A2")
    Application.CutCopyMode = False
    End With
If ActiveSheet.AutoFilterMode Then
ActiveSheet.AutoFilterMode = False
End If

'----------------------------------------------------------------------------------


 lLastRowDeDuped = Cells(Rows.Count, lFirstWriteColumn).End(xlUp).Row
    
    
     '''''''''''''''''''''''''''''''''''''PROJECTION
     With Worksheets("Salary")
        lLastSalaryRow = .Cells(.Rows.Count, "B").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, 2).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
         ActiveSheet.Range("$K$1:$AX$1048576").RemoveDuplicates Columns:=39, Header:= _
        xlYes
    End With
    ''Add Value Column
    Cells(1, lLastHTeamCol + 3).Value = ChrW(931) & " Value"
    With Range(Cells(2, lLastHTeamCol + 3), Cells(lLastRowDeDuped, lLastHTeamCol + 3))
        .Formula2R1C1 = "=(RC[-1]/RC[-2])*1000"
        Application.Calculate
        .Value = .Value
     End With
     
       With Range("AX2", Range("AX" & Rows.Count).End(xlUp))
        .Value = Evaluate(Replace("if(@<1.65,0,if(@="""","""",@))", "@", .Address))
        End With
        
        ActiveWorkbook.Worksheets("Worksheet").Sort.SortFields.Clear
    ActiveWorkbook.Worksheets("Worksheet").Sort.SortFields.Add2 Key:=Range( _
        "AX2:AX" & lLastRow), SortOn:=xlSortOnValues, Order:=xlAscending, DataOption:= _
        xlSortNormal
        
         With ActiveWorkbook.Worksheets("Worksheet").Sort
        .SetRange Range("K2:BE" & lLastRow)
        .Header = xlGuess
        .MatchCase = False
        .Orientation = xlTopToBottom
        .SortMethod = xlPinYin
        .Apply
    End With
    With wksData
        .Range("A2:I26").Cut names.Range("G2")
        Application.CutCopyMode = False
      End With
    ActiveSheet.Range("K1:AX" & lLastRow).AutoFilter Field:=40, Criteria1:="0"
    Range("K2:AX" & lLastRow).Select
    Application.DisplayAlerts = False
    Selection.Delete
    ActiveSheet.Range("A1").Select
    ActiveSheet.Range("K1:AX" & lLastRow).AutoFilter Field:=40
       With names
    .Range("G2:O26").Cut wksData.Range("A2")
    Application.CutCopyMode = False
    End With
    If ActiveSheet.AutoFilterMode Then
ActiveSheet.AutoFilterMode = False
End If

  '''''''''''''''''''''''''''''''''''''TEAM
     With Worksheets("Salary")
        lLastSalaryRow = .Cells(.Rows.Count, "B").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, 2).Value, _
            Replacement:=Worksheets("Salary").Cells(lRowIndex2, 5).Value, LookAt:=xlWhole, _
            SearchOrder:=xlByRows, MatchCase:=False, SearchFormat:=False, _
            ReplaceFormat:=False
    Next '''''''''''''''''''''''''''
   
    ''Add Team Stack Column
    Cells(1, lLastHTeamCol + 4).Value = ChrW(931) & " Stack"
    With Range(Cells(2, lLastHTeamCol + 4), Cells(lLastRowDeDuped, lLastHTeamCol + 4))
        .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 + 5).Value = ChrW(931) & " Stack POS"
    With Range(Cells(2, lLastHTeamCol + 5), Cells(lLastRowDeDuped, lLastHTeamCol + 5))
    
    .Formula2R1C1 = "=TEXTJOIN("","",1,IF(RC[-13]:RC[-4]=RC[-1],R1C[-13]:R1C[-4],""""))"
        Application.Calculate
        .Value = .Value
    End With
    '------------------------------------------------------------------------------------------
    ''How many on team?? Remove Stacks with more than 4 players from same team
    Cells(1, lLastHTeamCol + 6).Value = ChrW(931) & " Commas"
    With Range(Cells(2, lLastHTeamCol + 6), Cells(lLastRowDeDuped, lLastHTeamCol + 6))
    
    .Formula2R1C1 = "=LEN(TRIM(RC[-1]))-LEN(SUBSTITUTE(TRIM(RC[-1]),"","",""""))+1"
        Application.Calculate
        .Value = .Value
    End With
    
      With Range("BA2", Range("BA" & Rows.Count).End(xlUp))
        .Value = Evaluate(Replace("if(@>4,0,if(@="""","""",@))", "@", .Address))
        End With
        
     ActiveWorkbook.Worksheets("Worksheet").Sort.SortFields.Clear
    ActiveWorkbook.Worksheets("Worksheet").Sort.SortFields.Add2 Key:=Range( _
        "BA2:BA" & lLastRow), SortOn:=xlSortOnValues, Order:=xlAscending, DataOption:= _
        xlSortNormal
        
         With ActiveWorkbook.Worksheets("Worksheet").Sort
        .SetRange Range("K2:BE" & lLastRow)
        .Header = xlGuess
        .MatchCase = False
        .Orientation = xlTopToBottom
        .SortMethod = xlPinYin
        .Apply
    End With
    With wksData
        .Range("A2:I26").Cut names.Range("G2")
        Application.CutCopyMode = False
      End With
    ActiveSheet.Range("K1:BA" & lLastRow).AutoFilter Field:=43, Criteria1:="0"
    Range("K2:BA" & lLastRow).Select
    Application.DisplayAlerts = False
    Selection.Delete
    ActiveSheet.Range("A1").Select
    ActiveSheet.Range("K1:BA" & lLastRow).AutoFilter Field:=43
       With names
    .Range("G2:O26").Cut wksData.Range("A2")
    Application.CutCopyMode = False
    End With
    If ActiveSheet.AutoFilterMode Then
ActiveSheet.AutoFilterMode = False
End If
    Columns("BA").Delete
    ''---------------------------------------------------------------------------------------------------------------------------
     ''Removes rows with two running backs from the primary team stack
     
     ActiveWorkbook.Worksheets("Worksheet").Sort.SortFields.Clear
    ActiveWorkbook.Worksheets("Worksheet").Sort.SortFields.Add2 Key:=Range( _
        "AZ2:AZ" & lLastRow), SortOn:=xlSortOnValues, Order:=xlAscending, DataOption:= _
        xlSortNormal
        
         With ActiveWorkbook.Worksheets("Worksheet").Sort
        .SetRange Range("K2:BE" & lLastRow)
        .Header = xlGuess
        .MatchCase = False
        .Orientation = xlTopToBottom
        .SortMethod = xlPinYin
        .Apply
    End With
    With wksData
        .Range("A2:I26").Cut names.Range("G2")
        Application.CutCopyMode = False
      End With
    ActiveSheet.Range("K1:AZ" & lLastRow).AutoFilter Field:=42, Criteria1:="=*RB1*", Operator:=xlAnd, Criteria2:="=*RB2*"
    Range("K2:AZ" & lLastRow).Select
    Application.DisplayAlerts = False
    Selection.Delete
    ActiveSheet.Range("A1").Select
    ActiveSheet.Range("K1:AZ" & lLastRow).AutoFilter Field:=42
       With names
    .Range("G2:O26").Cut wksData.Range("A2")
    Application.CutCopyMode = False
    End With
    If ActiveSheet.AutoFilterMode Then
ActiveSheet.AutoFilterMode = False
End If
'---------------------------------------------------------------------------------------------------------------------------------------------
    ''Add 2nd Team Stack Column
    Cells(1, lLastHTeamCol + 6).Value = ChrW(931) & " Stack2"
    With Range(Cells(2, lLastHTeamCol + 6), Cells(lLastRowDeDuped, lLastHTeamCol + 6))
     .Formula2R1C1 = "=IFERROR(INDEX(RC[-14]:RC[-5],MODE(IF((RC[-14]:RC[-5]<>"""")*(RC[-14]:RC[-5]<>INDEX(RC[-14]:RC[-5],MODE(IF(RC[-14]:RC[-5]<>"""",MATCH(RC[-14]:RC[-5],RC[-14]:RC[-5],0))))),MATCH(RC[-14]:RC[-5],RC[-14]:RC[-5],0)))),"""")"
      Application.Calculate
    .Value = .Value
    End With
    
    ''Add 2nd Team Stack Pos
    Cells(1, lLastHTeamCol + 7).Value = ChrW(931) & " Stack2 POS"
    With Range(Cells(2, lLastHTeamCol + 7), Cells(lLastRowDeDuped, lLastHTeamCol + 7))
    
    .Formula2R1C1 = "=TEXTJOIN("","",1,IF(RC[-16]:RC[-7]=RC[-1],R1C[-16]:R1C[-7],""""))"
        Application.Calculate
        .Value = .Value
    End With
    ''---------------------------------------------------------------------------------------------------------------------------
     ''Removes rows with two running backs from the secondary team stack
     
     ActiveWorkbook.Worksheets("Worksheet").Sort.SortFields.Clear
    ActiveWorkbook.Worksheets("Worksheet").Sort.SortFields.Add2 Key:=Range( _
        "BB2:BB" & lLastRow), SortOn:=xlSortOnValues, Order:=xlAscending, DataOption:= _
        xlSortNormal
        
         With ActiveWorkbook.Worksheets("Worksheet").Sort
        .SetRange Range("K2:BE" & lLastRow)
        .Header = xlGuess
        .MatchCase = False
        .Orientation = xlTopToBottom
        .SortMethod = xlPinYin
        .Apply
    End With
    With wksData
        .Range("A2:I26").Cut names.Range("G2")
        Application.CutCopyMode = False
      End With
    ActiveSheet.Range("K1:BB" & lLastRow).AutoFilter Field:=44, Criteria1:="=*RB1*", Operator:=xlAnd, Criteria2:="=*RB2*"
    Range("K2:BB" & lLastRow).Select
    Application.DisplayAlerts = False
    Selection.Delete
    ActiveSheet.Range("A1").Select
    ActiveSheet.Range("K1:BB" & lLastRow).AutoFilter Field:=44
       With names
    .Range("G2:O26").Cut wksData.Range("A2")
    Application.CutCopyMode = False
    End With
    If ActiveSheet.AutoFilterMode Then
ActiveSheet.AutoFilterMode = False
End If
'---------------------------------------------------------------------------------------------------------------------------------------------
    
    'Filter 0-1
    Cells(1, lLastHTeamCol + 8).Value = ChrW(931) & " Filter"
    With Range(Cells(2, lLastHTeamCol + 8), Cells(lLastRowDeDuped, lLastHTeamCol + 8))
    
    End With
    
    'Player 1 Filter
    Cells(1, lLastHTeamCol + 9).Value = ChrW(931) & " Player1"
    With Range(Cells(2, lLastHTeamCol + 9), Cells(lLastRowDeDuped, lLastHTeamCol + 9))
    
    End With
    
    'Player 2 Filter
    Cells(1, lLastHTeamCol + 10).Value = ChrW(931) & " Player2"
    With Range(Cells(2, lLastHTeamCol + 10), Cells(lLastRowDeDuped, lLastHTeamCol + 10))
    
    End With
    
    'Sort each row
    
    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 ?????
    
   
    
    'Remove Salary Columns
    Range(Cells(2, lFirstHSortColumn), Cells(lLastRowDeDuped, lLastHTeamCol)).EntireColumn.Delete

    
    
    sOutput = lLastIteration & vbTab & " possible combinations" & vbLf & _
        Format(Now() - dteStart, "hh:mm:ss") & " to process."
    
    ActiveSheet.UsedRange.Columns.AutoFit
    MsgBox sOutput, , "Output Report"
    Debug.Print sOutput
        Call OptimizeCode_End
    Application.StatusBar = False
End_Sub:
    
    
End Sub
```


----------



## cspengel (Nov 25, 2022)

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



```
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
```


----------



## johnnyL (Dec 2, 2022)

I have some time to look at this again.

Your comments in the code mention sorting,

What I want to know is what exactly should be done withe the original data,

As far as I can see, it looks like you want to:
1) Create all of the possible combinations from the columns of data in the 'Worksheet'
2) Remove combinations that result in duplicate entries in the same combination row
3) Remove all remaining rows of combinations that are duplicates of previous rows
4) Display those results to the 'Worksheet' sheet in the K2 range
5) Copy those same results to 3 more ranges of columns
6) Process rest of your code

Does that sound right?


----------



## cspengel (Dec 2, 2022)

johnnyL said:


> I have some time to look at this again.
> 
> Your comments in the code mention sorting,
> 
> ...


Yes that is exactly right. As for "
what exactly should be done with the the original data", what data are you referring to? Sorry just want to be clear.


----------



## johnnyL (Dec 2, 2022)

Original data refers to the names in the A:I range of the 'Worksheet' as in how you want to use it for processing.


----------



## cspengel (Dec 3, 2022)

johnnyL said:


> Original data refers to the names in the A:I range of the 'Worksheet' as in how you want to use it for processing.


Well currently, the names in range A:I are copied and pasted in the salary sheet after each filter and delete. Then they are cut and pasted back to there original location in the Worksheet so they are not removed during the macro. Not sure if that's what you mean.


----------



## johnnyL (Dec 3, 2022)

No it wasn't what I meant, but I think the rest of your previous post helps me understand I am on the right track.

One other question, does the duplicate row search actually reduce any rows? I am trying to imagine when that would occur, the only way  I can think of that needing to be checked for is if duplicate names in the same column on the 'Worksheet' sheet existed.

What do you think?


----------



## cspengel (Dec 3, 2022)

johnnyL said:


> No it wasn't what I meant, but I think the rest of your previous post helps me understand I am on the right track.
> 
> One other question, does the duplicate row search actually reduce any rows? I am trying to imagine when that would occur, the only way  I can think of that needing to be checked for is if duplicate names in the same column on the 'Worksheet' sheet existed.
> 
> What do you think?


It actually does reduce quite a bit. It basically occurs because some names may be utilized in multiple columns therefore it rewrites the same row in a different order. I.e

Cousins , davante, doubs, chase, colts
Cousins, doubs, davante, chase, colts

I have been testing varying methods though. Removing duplicate projections also accomplishes the same task, but could remove other rows with different players, but the same projection.


----------



## johnnyL (Dec 3, 2022)

cspengel said:


> It actually does reduce quite a bit. It basically occurs because some names may be utilized in multiple columns therefore it rewrites the same row in a different order. I.e
> 
> Cousins , davante, doubs, chase, colts
> Cousins, doubs, davante, chase, colts


But wouldn't those names fall into different positions? Ex. WR1,WR2, RB,etc?

Are you saying that the position they fall in doesn't matter, it's more of a 9 member 'team' aspect?


----------



## cspengel (Dec 3, 2022)

johnnyL said:


> But wouldn't those names fall into different positions? Ex. WR1,WR2, RB,etc?
> 
> Are you saying that the position they fall in doesn't matter, it's more of a 9 member 'team' aspect?


It's more of a 9 player team aspect. The only important thing is a QB must remain under qb category.  The sort will never move him from that position. The WR's must remain under any of the WR spots, same for RB's, TE , and defense. The number associated to the position does not matter, but the category itself does as there 1QB slot, 2RB slots, 3 WR slots, 1 TE slot, 1 flex spot( which can be a RB,WR, or TE) and 1 Defense slot. Hope that helps!


----------



## johnnyL (Dec 3, 2022)

I am starting to understand why your code takes sooo long to run.


----------



## cspengel (Dec 3, 2022)

johnnyL said:


> I am starting to understand why your code takes sooo long to run.


Haha, yeah.. I would say I am happy that it is much quicker than the original hour and a half it was at before I made this thread. Even if a few extra minutes were added to do more than a million combinations, that would be okay with me. I've been utilizing the removal of duplicates with the values in the Value column as well and can get a good 300 rows(or lineups) out of the the many thousands and thousands of original combinations to choose from.


----------



## cspengel (Nov 25, 2022)

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



```
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
```


----------



## johnnyL (Dec 5, 2022)

Ok, I have to ask.

The duplicate check for rows, is that supposed to be duplicate rows for unique names in any order or of the data that results from the formulas?

I would think that the names should be checked, but I think your script looks at all of the formula columns.


----------



## cspengel (Dec 5, 2022)

johnnyL said:


> Ok, I have to ask.
> 
> The duplicate check for rows, is that supposed to be duplicate rows for unique names in any order or of the data that results from the formulas?


Duplicate check for rows is supposed to be of unique names in any order. I'm running into a separate issue I just noticed today. For some reason my projections are not adding up correctly for some rows. Been trying to go back and figure out what could be causing it. 😒.  It's odd..I could have 400 printed combos and 370 will be correctly added and 30 will be not. It's replacing the wrong name with wrong projection or salary. That or during the filter and delete its jumbling data. Ugh.


----------



## johnnyL (Dec 5, 2022)

As I said, it appears that the code is deleting rows, according to values from the formulas, as opposed to the names.


----------



## johnnyL (Dec 5, 2022)

If you say the names are supposed to be the deleting factor, I will continue playing with the code to correct it, if not, please specify what should be the factor for deleting rows.


----------



## cspengel (Dec 5, 2022)

johnnyL said:


> As I said, it appears that the code is deleting rows, according to values from the formulas, as opposed to the names.


Well I have several removal of duplicates. One removes duplicates where the same name appears 2 in the same row. One where another row matches another row regardless of order. One removes duplicates of rows that have the same "value" rating. One removes duplicates with the same "projection". Basically just trying to eliminate a lot of combinations. I thought I had it all set up right, but I guess I don't. I don't see how only a few rows can be affected out of hundreds being calculated correctly. Each removal is done after there calculation. So after value is calculated, duplicate values in the value column are removed. But the whole row is supposed to be removed. Same with projection.


----------



## johnnyL (Dec 5, 2022)

cspengel said:


> Well I have several removal of duplicates. One removes duplicates where the same name appears 2 in the same row. One where another row matches another row regardless of order.



That is what I thought your goal was and what I have based my code on, the other stuff could be added later if needed, but please don't keep changing the original question. Additional threads could be used for that.


----------



## cspengel (Dec 5, 2022)

johnnyL said:


> That is what I thought your goal was and what I have based my code on, the other stuff could be added later if needed, but please don't keep changing the original question. Additional threads could be used for that.


Alright, sorry about that!


----------



## johnnyL (Dec 5, 2022)

So are you willing to say the names, no duplicates in same row & names in other rows (order doesn't matter) should determine which rows get deleted?


----------



## cspengel (Dec 5, 2022)

johnnyL said:


> So are you willing to say the names, no duplicates in same row & names in other rows (order doesn't matter) should determine which rows get deleted?


Yes that is correct


----------



## johnnyL (Dec 5, 2022)

Ok, I will continue on in the quest, 

I have thus far redone what you have previously notated as steps 2 & 3. The original steps 2 & 3 took over 15 minutes for me, The revised code for steps 2 & 3 takes about 5 1/2 minutes.

I will continue on in about 12 hrs, after some sleep, with the rest of the steps,


----------



## cspengel (Nov 25, 2022)

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



```
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
```


----------



## cspengel (Dec 5, 2022)

johnnyL said:


> Ok, I will continue on in the quest,
> 
> I have thus far redone what you have previously notated as steps 2 & 3. The original steps 2 & 3 took over 15 minutes for me, The revised code for steps 2 & 3 takes about 5 1/2 minutes.
> 
> I will continue on in about 12 hrs, after some sleep, with the rest of the steps,


Oh wow!
Really appreciate your help. I kept messing with things and found myself forgetting what I was doing and just confusing myself.


----------



## johnnyL (Dec 5, 2022)

Your script is asking a lot of Excel, but we will get the time down far from the original code.


----------



## johnnyL (Dec 5, 2022)

Ok, here is what I have come up with thus far, starting with the original code & sheets data. I redid some of the code and rearranged some of the code. I started out by adding what your comments were as far as what each section does, but I haven't really spent too much time on editing those comments to reflect the changes I made, so you may want to go through & update those.

The code:
1) Calculates the combinations of the names, only saves the combinations with no duplicate names in the same combination
2) Sorts all combinations by rows & removes rows with duplicate entries previously seen
3) Removes all combinations with salaries > 60000
4) Then it copies the remaining combinations to the other two ranges for the other calculations


Original code took about 33 minutes to complete for 786240 possible combinations.

Revised code results:

```
Create all combinations & remove rows with duplicate entries in the same row completed in 00:06:51
Sort all combinations by rows & remove rows with duplicate entries previously seen completed in 00:02:17
Remove all combinations with salaries > 60000 completed in 00:06:07
786240   possible combinations
60533    unique name combinations
60533    printed.

00:15:38 to process.
```

Please let me know what your thoughts are after testing the revised code.


----------



## cspengel (Dec 5, 2022)

johnnyL said:


> Ok, here is what I have come up with thus far, starting with the original code & sheets data. I redid some of the code and rearranged some of the code. I started out by adding what your comments were as far as what each section does, but I haven't really spent too much time on editing those comments to reflect the changes I made, so you may want to go through & update those.
> 
> The code:
> 1) Calculates the combinations of the names, only saves the combinations with no duplicate names in the same combination
> ...


Sounds great! Where is the revised code?


----------



## johnnyL (Dec 5, 2022)

Dang it! LOL I do that more times than I care to say. I write up a post mentioning changes and what not, then I forget to post the code.

Sorry about that.


```
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 NameCombosV10()
    'https://www.mrexcel.com/forum/excel-questions/1106189-all-combinations-multiple-columns-without-duplicates.html
'
    Dim bFoundSalary                    As Boolean
    Dim bShowError                      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 ColumnNumber                    As Long
    Dim currow                          As Long
    Dim firstrow                        As Long, lLastRow                       As Long
    Dim lColumnIndex                    As Long
    Dim lFirstHSortColumn               As Long, lFirstHSortColumn2             As Long
    Dim lFirstHTeamCol                  As Long, lLastHTeamCol                  As Long
    Dim lFirstWriteColumn               As Long, lLastWriteColumn               As Long
    Dim lIndex                          As Long
    Dim lIterationCount                 As Long, lLastIteration                 As Long
    Dim lLastColumn                     As Long
    Dim lLastHSortColumn                As Long, lLastHSortColumn2              As Long
    Dim lLastRowDeDuped                 As Long
    Dim lLastSalaryRow                  As Long
    Dim lLastUsedColumn                 As Long
    Dim lRowIndex                       As Long
    Dim lWriteColumn                    As Long, lWriteRow                      As Long
    Dim UniqueArrayRow                  As Long
    Dim x                               As Long
    Dim oSD                             As Object
    Dim cel                             As Range
    Dim rngDataBlock                    As Range
    Dim rngReplace                      As Range, rngReplace2                   As Range, rngReplace3                   As Range
    Dim rngSortRange                    As Range
    Dim SortRowRange                    As Range
    Dim WorksheetNameRange              As Range
    Dim sErrorMsg                       As String
    Dim sMissingSalary                  As String
    Dim sOutput                         As String
    Dim aryDeDupe                       As Variant
    Dim aryNames                        As Variant
    Dim NoDupeRowArray()                As Variant, NoDupeRowShortenedArray()   As Variant
    Dim SalarySheetFullArray            As Variant, SalarySheetShortenedArray() As Variant
    Dim TempArray                       As Variant
    Dim UniqueWorksheetNamesArray       As Variant
    Dim WorksheetArray                  As Variant
    Dim WorksheetColumnArray()          As Variant
    Dim names                           As Worksheet
    Dim wks                             As Worksheet
    Dim wksData                         As Worksheet
'
'-------------------------------------------------------------------------------------------------------------------------------
'
    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."
'
        Call OptimizeCode_End
    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
        For lIndex = LBound(oSD.Keys) To UBound(oSD.Keys)
            sMissingSalary = sMissingSalary & ", " & oSD.Keys(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
'
        Call OptimizeCode_End
    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"
'
        Call OptimizeCode_End
    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
'
    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
            Call OptimizeCode_End
    End Select
'
'-------------------------------------------------------------------------------------------------------------------------------
'
' 2) Clear all columns to the right of Column I on the "Worksheet" sheet. Copy headers from A1:I1 on the "Worksheet" sheet to K1:S1 on the "Worksheet" sheet.
'    Add header "ComboID" to T1 on the "Worksheet" sheet. Create the combinations & if there are no duplicate names in the same combination row then write the
'    combination to K row#:S row# on the "Worksheet" sheet & write lIterationCount to T row# on the "Worksheet" sheet.
'
    dteStart = Now()
    StartTime = Now()
'
    Application.StatusBar = "Calculating name combinations & saving combinations with no duplicate names in same combination ..."
    DoEvents
'
    'Clear all columns right of input range
    If lLastUsedColumn > lLastColumn Then
        Range(Cells(1, lLastColumn + 1), Cells(1, lLastUsedColumn)).EntireColumn.ClearContents
    End If
'
' Save Worksheet data into 2D 1 based WorksheetArray
    Set WorksheetNameRange = wksData.Range("A2:" & Split(Cells(1, lLastColumn).Address, "$")(1) & wksData.Range("A1").CurrentRegion.Find("*", , xlFormulas, , xlByRows, xlPrevious).Row)
    WorksheetArray = WorksheetNameRange
'
    ReDim NoDupeRowArray(1 To lLastIteration, 1 To lLastColumn + 1)
'
    Cells(1, lLastWriteColumn + 1).Value = "ComboID"
'
    'Add Output Header
    Range(Cells(1, 1), Cells(1, lLastColumn)).Copy Destination:=Cells(1, lFirstWriteColumn)
'
' Load data from 'Worksheet', each column of data will be loaded into a separate array
    ReDim WorksheetColumnArray(1 To lLastColumn)                                                        ' Set the # of arrays in 'jagged' array WorksheetColumnArray
'
    For ColumnNumber = 1 To lLastColumn                                                                 ' Loop through the columns of 'Worksheet'
        lLastRow = Cells(Rows.Count, ColumnNumber).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(ColumnNumber) = 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(ColumnNumber)(ArrayRow, 1) = WorksheetArray(ArrayRow, ColumnNumber)    '       Save the data to WorksheetColumnArray()
        Next                                                                                            '   Loop back
    Next                                                                                                ' Loop back
'
    'Start checking combinations
    lIterationCount = 0                                                                                 ' Reset lIterationCount
    lWriteRow = 0                                                                                       ' Reset lWriteRow
'
    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
'
' Initialize the scripting dictionary
                                        Set oSD = CreateObject("Scripting.Dictionary")
                                        oSD.CompareMode = vbTextCompare
'
' Check for duplicates in same row before saving to array
' Load names into scripting dictionary
                                        For x = 1 To 1                                                  '                                   Set up 'Fake loop' to allow exiting
                                            If Not oSD.Exists(WorksheetColumnArray(9)(ColumnI_Row, 1)) Then '                                   If name not previously seen in this row then ...
                                                oSD.Add WorksheetColumnArray(9)(ColumnI_Row, 1), ""     '                                           Save the name to the dictionary row
                                            Else                                                        '                                       Else ...
                                                Exit For                                                '                                           Exit this 'Fake loop'
                                            End If
'
                                            If Not oSD.Exists(WorksheetColumnArray(8)(ColumnH_Row, 1)) Then '                                   Same as previous /\ /\ /\
                                                oSD.Add WorksheetColumnArray(8)(ColumnH_Row, 1), ""
                                            Else
                                                Exit For
                                            End If
'
                                            If Not oSD.Exists(WorksheetColumnArray(7)(ColumnG_Row, 1)) Then '                                   Same as previous /\ /\ /\
                                                oSD.Add WorksheetColumnArray(7)(ColumnG_Row, 1), ""
                                            Else
                                                Exit For
                                            End If
'
                                            If Not oSD.Exists(WorksheetColumnArray(6)(ColumnF_Row, 1)) Then '                                   Same as previous /\ /\ /\
                                                oSD.Add WorksheetColumnArray(6)(ColumnF_Row, 1), ""
                                            Else
                                                Exit For
                                            End If
'
                                            If Not oSD.Exists(WorksheetColumnArray(5)(ColumnE_Row, 1)) Then '                                   Same as previous /\ /\ /\
                                                oSD.Add WorksheetColumnArray(5)(ColumnE_Row, 1), ""
                                            Else
                                                Exit For
                                            End If
'
                                            If Not oSD.Exists(WorksheetColumnArray(4)(ColumnD_Row, 1)) Then '                                   Same as previous /\ /\ /\
                                                oSD.Add WorksheetColumnArray(4)(ColumnD_Row, 1), ""
                                            Else
                                                Exit For
                                            End If
'
                                            If Not oSD.Exists(WorksheetColumnArray(3)(ColumnC_Row, 1)) Then '                                   Same as previous /\ /\ /\
                                                oSD.Add WorksheetColumnArray(3)(ColumnC_Row, 1), ""
                                            Else
                                                Exit For
                                            End If
'
                                            If Not oSD.Exists(WorksheetColumnArray(2)(ColumnB_Row, 1)) Then '                                   Same as previous /\ /\ /\
                                                oSD.Add WorksheetColumnArray(2)(ColumnB_Row, 1), ""
                                            Else
                                                Exit For
                                            End If
'
                                            If Not oSD.Exists(WorksheetColumnArray(1)(ColumnA_Row, 1)) Then _
                                                    oSD.Add WorksheetColumnArray(1)(ColumnA_Row, 1), "" '                                       If name not previously seen in this row then ...
'                                                                                                       '                                               Save the name to the dictionary row
                                        Next                                                            '                                   Exit 'Fake loop'
'
                                        If UBound(oSD.Keys) + 1 = lLastColumn Then                      '                                   If no duplicates found in row then ...
' The current row had names and no duplicates
'
' Point to the next blank row
                                            lWriteRow = lWriteRow + 1                                               '                           Increment lWriteRow
'
                                            NoDupeRowArray(lWriteRow, 1) = WorksheetColumnArray(1)(ColumnA_Row, 1)  '                           Save name from column A to NoDupeRowArray
                                            NoDupeRowArray(lWriteRow, 2) = WorksheetColumnArray(2)(ColumnB_Row, 1)  '                           Save name from column B to NoDupeRowArray
                                            NoDupeRowArray(lWriteRow, 3) = WorksheetColumnArray(3)(ColumnC_Row, 1)  '                           Save name from column C to NoDupeRowArray
                                            NoDupeRowArray(lWriteRow, 4) = WorksheetColumnArray(4)(ColumnD_Row, 1)  '                           Save name from column D to NoDupeRowArray
                                            NoDupeRowArray(lWriteRow, 5) = WorksheetColumnArray(5)(ColumnE_Row, 1)  '                           Save name from column E to NoDupeRowArray
                                            NoDupeRowArray(lWriteRow, 6) = WorksheetColumnArray(6)(ColumnF_Row, 1)  '                           Save name from column F to NoDupeRowArray
                                            NoDupeRowArray(lWriteRow, 7) = WorksheetColumnArray(7)(ColumnG_Row, 1)  '                           Save name from column G to NoDupeRowArray
                                            NoDupeRowArray(lWriteRow, 8) = WorksheetColumnArray(8)(ColumnH_Row, 1)  '                           Save name from column H to NoDupeRowArray
                                            NoDupeRowArray(lWriteRow, 9) = WorksheetColumnArray(9)(ColumnI_Row, 1)  '                           Save name from column I to NoDupeRowArray
'
' Uncomment next row to see the lIterationCount for the printed row
                                            NoDupeRowArray(lWriteRow, lLastColumn + 1) = lIterationCount    '                                   Save lIterationCount to NoDupeRowArray
                                        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
'
' Write current combination rows to sheet
'
    NoDupeRowArray = ReDimPreserve(NoDupeRowArray, lWriteRow, lLastColumn + 1)                          ' Resize NoDupeRowArray to correct the actual rows used in the array
'
    wksData.Cells(2, lLastColumn + 2).Resize(UBound(NoDupeRowArray, 1), _
            UBound(NoDupeRowArray, 2)) = NoDupeRowArray                                                 ' Display NoDupeRowArray to 'Worksheet'
'
Debug.Print "Create all combinations & remove rows with duplicate entries in the same row completed " & _
        "in " & Format(Now() - StartTime, "hh:mm:ss")                                                   ' Display elapsed time for this process to the 'Immediate' window (CTRL+G) in VBE
'
'-------------------------------------------------------------------------------------------------------------------------------
'-------------------------------------------------------------------------------------------------------------------------------
'-------------------------------------------------------------------------------------------------------------------------------
'
' 4) Copy name combinations from columns K:S and pastes them in columns U:AC, AD:AL, AM:AU
'
    StartTime = Now()
'
    Application.StatusBar = "Sorting all combinations by rows & removing rows with duplicate entries previously seen ..."
    DoEvents
'
    '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) '' Rows for SALARY ... Copy K1:S & lLastRow to U1:AC & lLastRow
    lFirstHSortColumn = lLastWriteColumn + 2                                                                                ' 21 ie. column U
    lLastHSortColumn = Cells(1, Columns.Count).End(xlToLeft).Column                                                         ' 29 ie. column AC
'
'-------------------------------------------------------------------------------------------------------------------------------
'
' 6) Build an array from the combination names in columns K:S. States it excludes iteration # column. I am not sure what that is referencing.
'    May be the ComboID in column T. The duplicate combinations are then removed. Keep in mind Duplicates in ANY order are removed.
'    If the same players are used in a lineup, regardless of column, they are removed.
'
' Sort each row
    ActiveSheet.Sort.SortFields.Clear
'
    Set rngSortRange = Range(Cells(2, lFirstHSortColumn), Cells(lLastRow, lLastHSortColumn))
'
    For Each SortRowRange In rngSortRange.Rows
        SortRowRange.Sort Key1:=SortRowRange.Cells(1, 1), Order1:=xlAscending, Header:=xlNo, Orientation:=xlSortRows
    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
'
    ReDim aryDeDupe(0 To lLastHSortColumn - lFirstHSortColumn)
'
    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  ' *** This line reduces lines of data
    'Above line won't work unless there are parens around the Columns argument ????? ... This is normal behavior :)
'
Debug.Print "Sort all combinations by rows & remove rows with duplicate entries previously seen completed " & _
        "in " & Format(Now() - StartTime, "hh:mm:ss")                                                   ' Display elapsed time for this process to the 'Immediate' window (CTRL+G) in VBE
'
'-------------------------------------------------------------------------------------------------------------------------------
'
' 5) Replace copied names in column U:AC with the players respective salary data on "Salary" sheet. Column AV becomes "Salary" column and
'    the sum of columns U:AC is calculated. Max salary is declared at 60000. The data in A2:I26 is copied to the "Salary" sheet in cell G2:O26
'    before filter is applied. Autofilter is then applied to the range AV. If the value in AV is greater than 60000, the range K:BE for that row will be deleted.
'    The data copied to G2:O26 is then cut and pasted back to A2:I26 and autofilter is turned off.
'
       'Assumes the 'Salary' worksheet has names in the column A and salaries in column B starting in row 2
    'Replace HSort names with salary
'
    StartTime = Now()
'
    Application.StatusBar = "Removing all combination rows with salaries > 60000 ..."
    DoEvents
'
    With Worksheets("Salary") '''' SALARY
        lLastSalaryRow = .Cells(.Rows.Count, 1).End(xlUp).Row
    End With
'
    With CreateObject("scripting.dictionary")
        .CompareMode = vbTextCompare
'
        For Each cel In WorksheetNameRange                                                                          '   Loop through each cell in the WorksheetNameRange
            If cel <> "" Then                                                                                       '       If the cell is not blank then ...
                If Not .Exists(cel.Value) Then                                                                      '           If the value has not already been saved then ...
                    .Add cel.Value, cel.Value                                                                       '               Save the value
                End If
            End If
'
            UniqueWorksheetNamesArray = Application.Transpose(Array(.Keys))                                         '       Transpose results to 2D 1 based UniqueWorksheetNamesArray
        Next                                                                                                        '   Loop back
    End With
'
    SalarySheetFullArray = names.Range("A2:" & _
            Split(Cells(names.Cells.Find("*", , xlFormulas, , xlByColumns, xlPrevious).Column).Address, "$")(1) & lLastSalaryRow)   '   Save all of the data from the 'Salary' aheet into 2D 1 based SalarySheetFullArray
'
    ReDim SalarySheetShortenedArray(1 To UBound(SalarySheetFullArray, 1), 1 To UBound(SalarySheetFullArray, 2)) ' Set 2D 1 based SalarySheetShortenedArray to the same size as SalarySheetFullArray
'
    currow = 0                                                                                                      ' Initialize currow
'
    For UniqueArrayRow = 1 To UBound(UniqueWorksheetNamesArray, 1)                                                  ' Loop through the rows of UniqueWorksheetNamesArray
        For ArrayRow = 1 To UBound(SalarySheetFullArray, 1)                                                         '   Loop through the rows of SalarySheetFullArray
            If UniqueWorksheetNamesArray(UniqueArrayRow, 1) = SalarySheetFullArray(ArrayRow, 1) Then                '       If the name from UniqueWorksheetNamesArray is found in SalarySheetFullArray then ...
                currow = currow + 1                                                                                 '           Increment currow
'
                For lColumnIndex = 1 To UBound(SalarySheetFullArray, 2)                                             '           Loop through the columns of SalarySheetFullArray
                    SalarySheetShortenedArray(currow, lColumnIndex) = SalarySheetFullArray(ArrayRow, lColumnIndex)  '               Save the values to SalarySheetShortenedArray
                Next                                                                                                '           Loop back
            End If
        Next                                                                                                        '   Loop back
    Next                                                                                                            ' Loop back
'
    SalarySheetShortenedArray = Application.Transpose(SalarySheetShortenedArray)                                    ' Transpose SalarySheetShortenedArray so we can correct the size (row count)
'
    ReDim Preserve SalarySheetShortenedArray(1 To UBound(SalarySheetFullArray, 2), 1 To currow)                     ' Set the row count to actual used rows
'
    SalarySheetShortenedArray = Application.Transpose(SalarySheetShortenedArray)                                    ' Transpose back the SalarySheetShortenedArray
'
    lLastRow = Cells(Rows.Count, lFirstWriteColumn).End(xlUp).Row
'
    Set rngReplace = Range(Cells(2, lFirstHSortColumn), Cells(lLastRow, lLastHSortColumn))
'
    For lRowIndex = 1 To UBound(SalarySheetShortenedArray, 1)
        rngReplace.Replace What:=SalarySheetShortenedArray(lRowIndex, 1), _
                Replacement:=SalarySheetShortenedArray(lRowIndex, 2), LookAt:=xlWhole, _
                SearchOrder:=xlByRows, MatchCase:=False, SearchFormat:=False, ReplaceFormat:=False
    Next
'
    lLastRowDeDuped = Cells(Rows.Count, lFirstWriteColumn).End(xlUp).Row
'
    lLastHTeamCol = Cells(1, Columns.Count).End(xlToLeft).Column
'
' 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
        Set rngDataBlock = .Range(.Cells(1, lLastHTeamCol + 1), .Cells(lLastRow, lLastHTeamCol + 1))
    End With
'
    x = 60000
'
    With rngDataBlock
        .AutoFilter Field:=1, Criteria1:=">" & x
'
        On Error Resume Next
        .Range(Cells(2, lFirstWriteColumn), Cells(lLastRow, lLastHTeamCol + 9)).Delete Shift:=xlUp      '   This took almost 6 minutes :(
        On Error GoTo 0
    End With
'
' Turn off the Autofilter safely
    With wksData
        .AutoFilterMode = False
'
        If .FilterMode = True Then .ShowAllData
   End With
'
    wksData.Range("A2").Resize(UBound(WorksheetArray, 1), UBound(WorksheetArray, 2)) = WorksheetArray   ' Write original data back to wksData just in case it was deleted
'
Debug.Print "Remove all combinations with salaries > 60000 completed " & _
        "in " & Format(Now() - StartTime, "hh:mm:ss")                                                   ' Display elapsed time for this process to the 'Immediate' window (CTRL+G) in VBE
'
'-------------------------------------------------------------------------------------------------------------------------------
'
' 7) The names copied over to AD:AL are replaced with the corresponding players projection on the "Salary" sheet. The names copied over to AM:AU are replaced
'    with the corresponding players team located on the "Salary" Sheet. 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.
'
    Application.StatusBar = "Wrapping up ..."
    DoEvents
'
    lLastRow = Cells(Rows.Count, lFirstWriteColumn).End(xlUp).Row
'
    Range(Cells(1, lFirstWriteColumn), Cells(lLastRow, lLastWriteColumn)).Copy Destination:=Cells(1, lLastHSortColumn + 1) '' Rows for PROJECTION
'
    lLastHSortColumn2 = Cells(1, Columns.Count).End(xlToLeft).Column
'
    Range(Cells(1, lFirstWriteColumn), Cells(lLastRow, lLastWriteColumn)).Copy Destination:=Cells(1, lLastHSortColumn2 + 1) '' Rows for TEAM
'
    lLastRowDeDuped = Cells(Rows.Count, lFirstWriteColumn).End(xlUp).Row
'
    lFirstHSortColumn2 = lLastHSortColumn + 1
'
    lFirstHTeamCol = lLastHSortColumn2 + 1
    lLastHTeamCol = Cells(1, Columns.Count).End(xlToLeft).Column
'
    Set rngReplace2 = Range(Cells(2, lFirstHSortColumn2), Cells(lLastRow, lLastHSortColumn2))
    Set rngReplace3 = Range(Cells(2, lFirstHTeamCol), Cells(lLastRow, lLastHTeamCol))
'
    For lRowIndex = 1 To UBound(SalarySheetShortenedArray, 1)
'
'''''''''''''''''''''''''''''''''''''PROJECTION
        rngReplace2.Replace What:=SalarySheetShortenedArray(lRowIndex, 1), _
            Replacement:=SalarySheetShortenedArray(lRowIndex, 3), LookAt:=xlWhole, _
            SearchOrder:=xlByRows, MatchCase:=False, SearchFormat:=False, ReplaceFormat:=False
'
'
         '''''''''''''''''''''''''''''''''''''TEAM
        rngReplace3.Replace What:=SalarySheetShortenedArray(lRowIndex, 1), _
            Replacement:=SalarySheetShortenedArray(lRowIndex, 4), LookAt:=xlWhole, _
            SearchOrder:=xlByRows, MatchCase:=False, SearchFormat:=False, ReplaceFormat:=False
    Next
'
' Add Projection Column
    Cells(1, lLastHTeamCol + 2).Value = ChrW(931) & " Projection"
' Add Team Stack Column
    Cells(1, lLastHTeamCol + 3).Value = ChrW(931) & " Stack"
' Add Team Stack Pos
    Cells(1, lLastHTeamCol + 4).Value = ChrW(931) & " Stack POS"
' Add 2nd Team Stack Column
    Cells(1, lLastHTeamCol + 5).Value = ChrW(931) & " Stack2"
' Add 2nd Team Stack Pos
    Cells(1, lLastHTeamCol + 6).Value = ChrW(931) & " Stack2 POS"
' Filter 0-1
    Cells(1, lLastHTeamCol + 7).Value = ChrW(931) & " Filter"
' Player 1 Filter
    Cells(1, lLastHTeamCol + 8).Value = ChrW(931) & " Player1"
' Player 2 Filter
    Cells(1, lLastHTeamCol + 9).Value = ChrW(931) & " Player2"
'
    With Range(Cells(2, lLastHTeamCol + 2), Cells(lLastRowDeDuped, lLastHTeamCol + 2))
        .FormulaR1C1 = "=SUM(RC" & lFirstHSortColumn2 & ":RC" & lLastHSortColumn2 & ")"
        Application.Calculate
        .Value = .Value
    End With
'
    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
'
    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
'
    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
'
    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
'
'-------------------------------------------------------------------------------------------------------------------------------
'
' 8) "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 + 7), Cells(lLastRowDeDuped, lLastHTeamCol + 7))
    End With
'
    With Range(Cells(2, lLastHTeamCol + 8), Cells(lLastRowDeDuped, lLastHTeamCol + 8))
    End With
'
    With Range(Cells(2, lLastHTeamCol + 9), Cells(lLastRowDeDuped, lLastHTeamCol + 9))
    End With
'
'-------------------------------------------------------------------------------------------------------------------------------
'
' 9) 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(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
'
    Call OptimizeCode_End
'
    Debug.Print sOutput
    MsgBox sOutput, , "Output Report"
End Sub



Public Function ReDimPreserve(ArrayNameToPreserve, NewRowUbound, NewColumnUbound)
'
' Code inspired by Control Freak
'
' Redim & preserve 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 OldColumnUbound             As Long, OldRowUbound                As Long
    Dim NewArrayNameToPreserve()    As Variant
'
    ReDimPreserve = False
'
    If IsArray(ArrayNameToPreserve) Then                                                                    ' If the variable is an array then ...
        ReDim NewArrayNameToPreserve(1 To NewRowUbound + 1, 1 To NewColumnUbound + 1)                       '   Create a New 2D 1 based Array
        OldRowUbound = UBound(ArrayNameToPreserve, 1)                                                       '   Save row Ubound of original array
        OldColumnUbound = UBound(ArrayNameToPreserve, 2)                                                    '   Save column Ubound of original array
'
        For NewRow = LBound(ArrayNameToPreserve, 1) To NewRowUbound                                         '   Loop through rows of original array
            For NewColumn = LBound(ArrayNameToPreserve, 2) To NewColumnUbound                               '       Loop through columns of original array
                If OldRowUbound >= NewRow And OldColumnUbound >= NewColumn Then
                    NewArrayNameToPreserve(NewRow, NewColumn) = ArrayNameToPreserve(NewRow, NewColumn)      '               Append rows/columns to NewArrayNameToPreserve
                End If
            Next                                                                                            '       Loop back
        Next                                                                                                '   Loop back
'
        If IsArray(NewArrayNameToPreserve) Then ReDimPreserve = NewArrayNameToPreserve
    End If
End Function
```


----------



## cspengel (Dec 5, 2022)

johnnyL said:


> Dang it! LOL I do that more times than I care to say. I write up a post mentioning changes and what not, then I forget to post the code.
> 
> Sorry about that.
> 
> ...


Haha, no worries.

Edit: running a test now


----------



## johnnyL (Dec 5, 2022)

Did you copy the entire code and run it with similar data to the original code?


----------



## cspengel (Dec 5, 2022)

johnnyL said:


> Did you copy the entire code and run it with similar data to the original code?


It was running for a bit and then just received an error on this code regarding object defined.


```
wksData.Cells(2, lLastColumn + 2).Resize(UBound(NoDupeRowArray, 1), _
            UBound(NoDupeRowArray, 2)) = NoDupeRowArray                                                 ' Display NoDupeRowArray to 'Worksheet'
```

I have the code copied exactly as posted. And utilizing the data I posted on the first page. Will try to run it again


----------



## johnnyL (Dec 5, 2022)

Let me know, I will provide a link to a workbook for you.


----------



## cspengel (Dec 5, 2022)

johnnyL said:


> Let me know, I will provide a link to a workbook for you.


Yeah if you could that would be great. I think it has to do with names not matching on the salary sheet with what I have on the Worksheet. Does your code still have that popup box that lets you know which names are missing?


----------



## cspengel (Nov 25, 2022)

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



```
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
```


----------



## johnnyL (Dec 6, 2022)

Link to workbook is here


----------



## cspengel (Dec 6, 2022)

Code certainly looks cleaner! I ran a few tests. First with data in your workbook, then a second one removing some names on the "salary" sheet that are not used on the "worksheet". 1st took 11min and 30 seconds and second (with less names) took 16 min and 30 seconds. Not sure why it took longer. Also I noticed that the salary should be in column U after the macro runs, but none of the salaries show up and the header is not there. 
Thanks for your time with this! It seems to run around similar times to what was discussed on page 3.


----------



## johnnyL (Dec 6, 2022)

If you took the time to look at the code, you would see that I added code to not make you have to worry about the amount of names/data in the ‘Salary’ sheet. The code grabs the needed data from the ‘Salary’ sheet and uses that for the script. IE. if there are 10 unique names on the ‘Worksheet’, the code will grab the required data for those 10 names from the ‘Salary’ sheet and use only that data.

As far as the columns being off by one, that is an easy correction.


----------



## cspengel (Dec 6, 2022)

johnnyL said:


> If you took the time to look at the code, you would see that I added code to not make you have to worry about the amount of names/data in the ‘Salary’ sheet. The code grabs the needed data from the ‘Salary’ sheet and uses that for the script. IE. if there are 10 unique names on the ‘Worksheet’, the code will grab the required data for those 10 names from the ‘Salary’ sheet and use only that data.
> 
> As far as the columns being off by one, that is an easy correction.


It looked like that's what it did 😅 . In that case, awesome! I really appreciate it. Wish I had the knowledge you did. I can be sitting here for hours messing with the same thing and get no where.


----------



## cspengel (Dec 6, 2022)

johnnyL said:


> If you took the time to look at the code, you would see that I added code to not make you have to worry about the amount of names/data in the ‘Salary’ sheet. The code grabs the needed data from the ‘Salary’ sheet and uses that for the script. IE. if there are 10 unique names on the ‘Worksheet’, the code will grab the required data for those 10 names from the ‘Salary’ sheet and use only that data.
> 
> As far as the columns being off by one, that is an easy correction.


Looking at your code I don't see why the columns are off by one. You have salary at lLastHTeamCol + 1 which is correct. Maybe VBA just isn't for me lol


----------



## johnnyL (Dec 6, 2022)

cspengel said:


> Looking at your code I don't see why the columns are off by one. You have salary at lLastHTeamCol + 1 which is correct. Maybe VBA just isn't for me lol



Thank you for testing & pointing out the flaw. Code from post #56 has been corrected:


```
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 NameCombosV10()
    'https://www.mrexcel.com/forum/excel-questions/1106189-all-combinations-multiple-columns-without-duplicates.html
'
    Dim bFoundSalary                    As Boolean
    Dim bShowError                      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 ColumnNumber                    As Long
    Dim currow                          As Long
    Dim firstrow                        As Long, lLastRow                       As Long
    Dim lColumnIndex                    As Long
    Dim lFirstHSortColumn               As Long, lFirstHSortColumn2             As Long
    Dim lFirstHTeamCol                  As Long, lLastHTeamCol                  As Long
    Dim lFirstWriteColumn               As Long, lLastWriteColumn               As Long
    Dim lIndex                          As Long
    Dim lIterationCount                 As Long, lLastIteration                 As Long
    Dim lLastColumn                     As Long
    Dim lLastHSortColumn                As Long, lLastHSortColumn2              As Long
    Dim lLastRowDeDuped                 As Long
    Dim lLastSalaryRow                  As Long
    Dim lLastUsedColumn                 As Long
    Dim lRowIndex                       As Long
    Dim lWriteColumn                    As Long, lWriteRow                      As Long
    Dim UniqueArrayRow                  As Long
    Dim x                               As Long
    Dim oSD                             As Object
    Dim cel                             As Range
    Dim rngDataBlock                    As Range
    Dim rngReplace                      As Range, rngReplace2                   As Range, rngReplace3                   As Range
    Dim rngSortRange                    As Range
    Dim SortRowRange                    As Range
    Dim WorksheetNameRange              As Range
    Dim sErrorMsg                       As String
    Dim sMissingSalary                  As String
    Dim sOutput                         As String
    Dim aryDeDupe                       As Variant
    Dim aryNames                        As Variant
    Dim NoDupeRowArray()                As Variant, NoDupeRowShortenedArray()   As Variant
    Dim SalarySheetFullArray            As Variant, SalarySheetShortenedArray() As Variant
    Dim TempArray                       As Variant
    Dim UniqueWorksheetNamesArray       As Variant
    Dim WorksheetArray                  As Variant
    Dim WorksheetColumnArray()          As Variant
    Dim names                           As Worksheet
    Dim wks                             As Worksheet
    Dim wksData                         As Worksheet
'
'-------------------------------------------------------------------------------------------------------------------------------
'
    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."
'
        Call OptimizeCode_End
    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
        For lIndex = LBound(oSD.Keys) To UBound(oSD.Keys)
            sMissingSalary = sMissingSalary & ", " & oSD.Keys(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
'
        Call OptimizeCode_End
    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"
'
        Call OptimizeCode_End
    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
'
    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
            Call OptimizeCode_End
    End Select
'
'-------------------------------------------------------------------------------------------------------------------------------
'
' 2) Clear all columns to the right of Column I on the "Worksheet" sheet. Copy headers from A1:I1 on the "Worksheet" sheet to K1:S1 on the "Worksheet" sheet.
'    Add header "ComboID" to T1 on the "Worksheet" sheet. Create the combinations & if there are no duplicate names in the same combination row then write the
'    combination to K row#:S row# on the "Worksheet" sheet & write lIterationCount to T row# on the "Worksheet" sheet.
'
    dteStart = Now()
    StartTime = Now()
'
    Application.StatusBar = "Step 1 of 4 Calculating name combinations & saving combinations with no duplicate names in same combination ..."
    DoEvents
'
    'Clear all columns right of input range
    If lLastUsedColumn > lLastColumn Then
        Range(Cells(1, lLastColumn + 1), Cells(1, lLastUsedColumn)).EntireColumn.ClearContents
    End If
'
' Save Worksheet data into 2D 1 based WorksheetArray
    Set WorksheetNameRange = wksData.Range("A2:" & Split(Cells(1, lLastColumn).Address, "$")(1) & wksData.Range("A1").CurrentRegion.Find("*", , xlFormulas, , xlByRows, xlPrevious).Row)
    WorksheetArray = WorksheetNameRange
'
    ReDim NoDupeRowArray(1 To lLastIteration, 1 To lLastColumn + 1)
'
    Cells(1, lLastWriteColumn + 1).Value = "ComboID"
'
    'Add Output Header
    Range(Cells(1, 1), Cells(1, lLastColumn)).Copy Destination:=Cells(1, lFirstWriteColumn)
'
' Load data from 'Worksheet', each column of data will be loaded into a separate array
    ReDim WorksheetColumnArray(1 To lLastColumn)                                                        ' Set the # of arrays in 'jagged' array WorksheetColumnArray
'
    For ColumnNumber = 1 To lLastColumn                                                                 ' Loop through the columns of 'Worksheet'
        lLastRow = Cells(Rows.Count, ColumnNumber).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(ColumnNumber) = 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(ColumnNumber)(ArrayRow, 1) = WorksheetArray(ArrayRow, ColumnNumber)    '       Save the data to WorksheetColumnArray()
        Next                                                                                            '   Loop back
    Next                                                                                                ' Loop back
'
    'Start checking combinations
    lIterationCount = 0                                                                                 ' Reset lIterationCount
    lWriteRow = 0                                                                                       ' Reset lWriteRow
'
    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
'
' Initialize the scripting dictionary
                                        Set oSD = CreateObject("Scripting.Dictionary")
                                        oSD.CompareMode = vbTextCompare
'
' Check for duplicates in same row before saving to array
' Load names into scripting dictionary
                                        For x = 1 To 1                                                  '                                   Set up 'Fake loop' to allow exiting
                                            If Not oSD.Exists(WorksheetColumnArray(9)(ColumnI_Row, 1)) Then '                                   If name not previously seen in this row then ...
                                                oSD.Add WorksheetColumnArray(9)(ColumnI_Row, 1), ""     '                                           Save the name to the dictionary row
                                            Else                                                        '                                       Else ...
                                                Exit For                                                '                                           Exit this 'Fake loop'
                                            End If
'
                                            If Not oSD.Exists(WorksheetColumnArray(8)(ColumnH_Row, 1)) Then '                                   Same as previous /\ /\ /\
                                                oSD.Add WorksheetColumnArray(8)(ColumnH_Row, 1), ""
                                            Else
                                                Exit For
                                            End If
'
                                            If Not oSD.Exists(WorksheetColumnArray(7)(ColumnG_Row, 1)) Then '                                   Same as previous /\ /\ /\
                                                oSD.Add WorksheetColumnArray(7)(ColumnG_Row, 1), ""
                                            Else
                                                Exit For
                                            End If
'
                                            If Not oSD.Exists(WorksheetColumnArray(6)(ColumnF_Row, 1)) Then '                                   Same as previous /\ /\ /\
                                                oSD.Add WorksheetColumnArray(6)(ColumnF_Row, 1), ""
                                            Else
                                                Exit For
                                            End If
'
                                            If Not oSD.Exists(WorksheetColumnArray(5)(ColumnE_Row, 1)) Then '                                   Same as previous /\ /\ /\
                                                oSD.Add WorksheetColumnArray(5)(ColumnE_Row, 1), ""
                                            Else
                                                Exit For
                                            End If
'
                                            If Not oSD.Exists(WorksheetColumnArray(4)(ColumnD_Row, 1)) Then '                                   Same as previous /\ /\ /\
                                                oSD.Add WorksheetColumnArray(4)(ColumnD_Row, 1), ""
                                            Else
                                                Exit For
                                            End If
'
                                            If Not oSD.Exists(WorksheetColumnArray(3)(ColumnC_Row, 1)) Then '                                   Same as previous /\ /\ /\
                                                oSD.Add WorksheetColumnArray(3)(ColumnC_Row, 1), ""
                                            Else
                                                Exit For
                                            End If
'
                                            If Not oSD.Exists(WorksheetColumnArray(2)(ColumnB_Row, 1)) Then '                                   Same as previous /\ /\ /\
                                                oSD.Add WorksheetColumnArray(2)(ColumnB_Row, 1), ""
                                            Else
                                                Exit For
                                            End If
'
                                            If Not oSD.Exists(WorksheetColumnArray(1)(ColumnA_Row, 1)) Then _
                                                    oSD.Add WorksheetColumnArray(1)(ColumnA_Row, 1), "" '                                       If name not previously seen in this row then ...
'                                                                                                       '                                               Save the name to the dictionary row
                                        Next                                                            '                                   Exit 'Fake loop'
'
                                        If UBound(oSD.Keys) + 1 = lLastColumn Then                      '                                   If no duplicates found in row then ...
' The current row had names and no duplicates
'
' Point to the next blank row
                                            lWriteRow = lWriteRow + 1                                               '                           Increment lWriteRow
'
                                            NoDupeRowArray(lWriteRow, 1) = WorksheetColumnArray(1)(ColumnA_Row, 1)  '                           Save name from column A to NoDupeRowArray
                                            NoDupeRowArray(lWriteRow, 2) = WorksheetColumnArray(2)(ColumnB_Row, 1)  '                           Save name from column B to NoDupeRowArray
                                            NoDupeRowArray(lWriteRow, 3) = WorksheetColumnArray(3)(ColumnC_Row, 1)  '                           Save name from column C to NoDupeRowArray
                                            NoDupeRowArray(lWriteRow, 4) = WorksheetColumnArray(4)(ColumnD_Row, 1)  '                           Save name from column D to NoDupeRowArray
                                            NoDupeRowArray(lWriteRow, 5) = WorksheetColumnArray(5)(ColumnE_Row, 1)  '                           Save name from column E to NoDupeRowArray
                                            NoDupeRowArray(lWriteRow, 6) = WorksheetColumnArray(6)(ColumnF_Row, 1)  '                           Save name from column F to NoDupeRowArray
                                            NoDupeRowArray(lWriteRow, 7) = WorksheetColumnArray(7)(ColumnG_Row, 1)  '                           Save name from column G to NoDupeRowArray
                                            NoDupeRowArray(lWriteRow, 8) = WorksheetColumnArray(8)(ColumnH_Row, 1)  '                           Save name from column H to NoDupeRowArray
                                            NoDupeRowArray(lWriteRow, 9) = WorksheetColumnArray(9)(ColumnI_Row, 1)  '                           Save name from column I to NoDupeRowArray
'
' Uncomment next row to see the lIterationCount for the printed row
                                            NoDupeRowArray(lWriteRow, lLastColumn + 1) = lIterationCount    '                                   Save lIterationCount to NoDupeRowArray
                                        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
'
' Write current combination rows to sheet
'
    NoDupeRowArray = ReDimPreserve(NoDupeRowArray, lWriteRow, lLastColumn + 1)                          ' Resize NoDupeRowArray to correct the actual rows used in the array
'
    wksData.Cells(2, lLastColumn + 2).Resize(UBound(NoDupeRowArray, 1), _
            UBound(NoDupeRowArray, 2)) = NoDupeRowArray                                                 ' Display NoDupeRowArray to 'Worksheet'
'
Debug.Print "Create all combinations & remove rows with duplicate entries in the same row completed " & _
        "in " & Format(Now() - StartTime, "hh:mm:ss")                                                   ' Display elapsed time for this process to the 'Immediate' window (CTRL+G) in VBE
'
'-------------------------------------------------------------------------------------------------------------------------------
'-------------------------------------------------------------------------------------------------------------------------------
'-------------------------------------------------------------------------------------------------------------------------------
'
' 4) Copy name combinations from columns K:S and pastes them in columns U:AC, AD:AL, AM:AU
'
    StartTime = Now()
'
    Application.StatusBar = "Step 2 of 4 Sorting all combinations by rows & removing rows with duplicate entries previously seen ..."
    DoEvents
'
    '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) '' Rows for SALARY ... Copy K1:S & lLastRow to U1:AC & lLastRow
    lFirstHSortColumn = lLastWriteColumn + 2                                                                                ' 21 ie. column U
    lLastHSortColumn = Cells(1, Columns.Count).End(xlToLeft).Column                                                         ' 29 ie. column AC
'
'-------------------------------------------------------------------------------------------------------------------------------
'
' 6) Build an array from the combination names in columns K:S. States it excludes iteration # column. I am not sure what that is referencing.
'    May be the ComboID in column T. The duplicate combinations are then removed. Keep in mind Duplicates in ANY order are removed.
'    If the same players are used in a lineup, regardless of column, they are removed.
'
' Sort each row
    ActiveSheet.Sort.SortFields.Clear
'
    Set rngSortRange = Range(Cells(2, lFirstHSortColumn), Cells(lLastRow, lLastHSortColumn))
'
    For Each SortRowRange In rngSortRange.Rows
        SortRowRange.Sort Key1:=SortRowRange.Cells(1, 1), Order1:=xlAscending, Header:=xlNo, Orientation:=xlSortRows
    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
'
    ReDim aryDeDupe(0 To lLastHSortColumn - lFirstHSortColumn)
'
    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  ' *** This line reduces lines of data
    'Above line won't work unless there are parens around the Columns argument ????? ... This is normal behavior :)
'
Debug.Print "Sort all combinations by rows & remove rows with duplicate entries previously seen completed " & _
        "in " & Format(Now() - StartTime, "hh:mm:ss")                                                   ' Display elapsed time for this process to the 'Immediate' window (CTRL+G) in VBE
'
'-------------------------------------------------------------------------------------------------------------------------------
'
' 5) Replace copied names in column U:AC with the players respective salary data on "Salary" sheet. Column AV becomes "Salary" column and
'    the sum of columns U:AC is calculated. Max salary is declared at 60000. The data in A2:I26 is copied to the "Salary" sheet in cell G2:O26
'    before filter is applied. Autofilter is then applied to the range AV. If the value in AV is greater than 60000, the range K:BE for that row will be deleted.
'    The data copied to G2:O26 is then cut and pasted back to A2:I26 and autofilter is turned off.
'
       'Assumes the 'Salary' worksheet has names in the column A and salaries in column B starting in row 2
    'Replace HSort names with salary
'
    StartTime = Now()
'
    Application.StatusBar = "Step 3 of 4 Removing all combination rows with salaries > 60000 ..."
    DoEvents
'
    With Worksheets("Salary") '''' SALARY
        lLastSalaryRow = .Cells(.Rows.Count, 1).End(xlUp).Row
    End With
'
    With CreateObject("scripting.dictionary")
        .CompareMode = vbTextCompare
'
        For Each cel In WorksheetNameRange                                                                          '   Loop through each cell in the WorksheetNameRange
            If cel <> "" Then                                                                                       '       If the cell is not blank then ...
                If Not .Exists(cel.Value) Then                                                                      '           If the value has not already been saved then ...
                    .Add cel.Value, cel.Value                                                                       '               Save the value
                End If
            End If
'
            UniqueWorksheetNamesArray = Application.Transpose(Array(.Keys))                                         '       Transpose results to 2D 1 based UniqueWorksheetNamesArray
        Next                                                                                                        '   Loop back
    End With
'
    SalarySheetFullArray = names.Range("A2:" & _
            Split(Cells(names.Cells.Find("*", , xlFormulas, , xlByColumns, xlPrevious).Column).Address, "$")(1) & lLastSalaryRow)   '   Save all of the data from the 'Salary' aheet into 2D 1 based SalarySheetFullArray
'
    ReDim SalarySheetShortenedArray(1 To UBound(SalarySheetFullArray, 1), 1 To UBound(SalarySheetFullArray, 2)) ' Set 2D 1 based SalarySheetShortenedArray to the same size as SalarySheetFullArray
'
    currow = 0                                                                                                      ' Initialize currow
'
    For UniqueArrayRow = 1 To UBound(UniqueWorksheetNamesArray, 1)                                                  ' Loop through the rows of UniqueWorksheetNamesArray
        For ArrayRow = 1 To UBound(SalarySheetFullArray, 1)                                                         '   Loop through the rows of SalarySheetFullArray
            If UniqueWorksheetNamesArray(UniqueArrayRow, 1) = SalarySheetFullArray(ArrayRow, 1) Then                '       If the name from UniqueWorksheetNamesArray is found in SalarySheetFullArray then ...
                currow = currow + 1                                                                                 '           Increment currow
'
                For lColumnIndex = 1 To UBound(SalarySheetFullArray, 2)                                             '           Loop through the columns of SalarySheetFullArray
                    SalarySheetShortenedArray(currow, lColumnIndex) = SalarySheetFullArray(ArrayRow, lColumnIndex)  '               Save the values to SalarySheetShortenedArray
                Next                                                                                                '           Loop back
            End If
        Next                                                                                                        '   Loop back
    Next                                                                                                            ' Loop back
'
    SalarySheetShortenedArray = Application.Transpose(SalarySheetShortenedArray)                                    ' Transpose SalarySheetShortenedArray so we can correct the size (row count)
'
    ReDim Preserve SalarySheetShortenedArray(1 To UBound(SalarySheetFullArray, 2), 1 To currow)                     ' Set the row count to actual used rows
'
    SalarySheetShortenedArray = Application.Transpose(SalarySheetShortenedArray)                                    ' Transpose back the SalarySheetShortenedArray
'
    lLastRow = Cells(Rows.Count, lFirstWriteColumn).End(xlUp).Row
'
    Set rngReplace = Range(Cells(2, lFirstHSortColumn), Cells(lLastRow, lLastHSortColumn))
'
    For lRowIndex = 1 To UBound(SalarySheetShortenedArray, 1)
        rngReplace.Replace What:=SalarySheetShortenedArray(lRowIndex, 1), _
                Replacement:=SalarySheetShortenedArray(lRowIndex, 2), LookAt:=xlWhole, _
                SearchOrder:=xlByRows, MatchCase:=False, SearchFormat:=False, ReplaceFormat:=False
    Next
'
    lLastRowDeDuped = Cells(Rows.Count, lFirstWriteColumn).End(xlUp).Row
'
    lLastHTeamCol = Cells(1, Columns.Count).End(xlToLeft).Column
'
' 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
        Set rngDataBlock = .Range(.Cells(1, lLastHTeamCol + 1), .Cells(lLastRow, lLastHTeamCol + 1))
    End With
'
    x = 60000
'
    With rngDataBlock
        .AutoFilter Field:=1, Criteria1:=">" & x
'
        On Error Resume Next
        .Range(Cells(2, lFirstWriteColumn), Cells(lLastRow, lLastHTeamCol + 9)).Delete Shift:=xlUp      '   This took almost 6 minutes :(
        On Error GoTo 0
    End With
'
' Turn off the Autofilter safely
    With wksData
        .AutoFilterMode = False
'
        If .FilterMode = True Then .ShowAllData
   End With
'
    wksData.Range("A2").Resize(UBound(WorksheetArray, 1), UBound(WorksheetArray, 2)) = WorksheetArray   ' Write original data back to wksData just in case it was deleted
'
Debug.Print "Remove all combinations with salaries > 60000 completed " & _
        "in " & Format(Now() - StartTime, "hh:mm:ss")                                                   ' Display elapsed time for this process to the 'Immediate' window (CTRL+G) in VBE
'
'-------------------------------------------------------------------------------------------------------------------------------
'
' 7) The names copied over to AD:AL are replaced with the corresponding players projection on the "Salary" sheet. The names copied over to AM:AU are replaced
'    with the corresponding players team located on the "Salary" Sheet. 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.
'
    Application.StatusBar = "Step 4 of 4 Wrapping up ..."
    DoEvents
'
    lLastRow = Cells(Rows.Count, lFirstWriteColumn).End(xlUp).Row
'
    Range(Cells(1, lFirstWriteColumn), Cells(lLastRow, lLastWriteColumn)).Copy Destination:=Cells(1, lLastHSortColumn + 2) '' Rows for PROJECTION
'
    lLastHSortColumn2 = Cells(1, Columns.Count).End(xlToLeft).Column
'
    Range(Cells(1, lFirstWriteColumn), Cells(lLastRow, lLastWriteColumn)).Copy Destination:=Cells(1, lLastHSortColumn2 + 1) '' Rows for TEAM
'
    lLastRowDeDuped = Cells(Rows.Count, lFirstWriteColumn).End(xlUp).Row
'
    lFirstHSortColumn2 = lLastHSortColumn + 2
'
    lFirstHTeamCol = lLastHSortColumn2 + 1
    lLastHTeamCol = Cells(1, Columns.Count).End(xlToLeft).Column
'
    Set rngReplace2 = Range(Cells(2, lFirstHSortColumn2), Cells(lLastRow, lLastHSortColumn2))
    Set rngReplace3 = Range(Cells(2, lFirstHTeamCol), Cells(lLastRow, lLastHTeamCol))
'
    For lRowIndex = 1 To UBound(SalarySheetShortenedArray, 1)
'
'''''''''''''''''''''''''''''''''''''PROJECTION
        rngReplace2.Replace What:=SalarySheetShortenedArray(lRowIndex, 1), _
            Replacement:=SalarySheetShortenedArray(lRowIndex, 3), LookAt:=xlWhole, _
            SearchOrder:=xlByRows, MatchCase:=False, SearchFormat:=False, ReplaceFormat:=False
'
'
         '''''''''''''''''''''''''''''''''''''TEAM
        rngReplace3.Replace What:=SalarySheetShortenedArray(lRowIndex, 1), _
            Replacement:=SalarySheetShortenedArray(lRowIndex, 4), LookAt:=xlWhole, _
            SearchOrder:=xlByRows, MatchCase:=False, SearchFormat:=False, ReplaceFormat:=False
    Next
'
' Add Projection Column
    Cells(1, lLastHTeamCol + 2).Value = ChrW(931) & " Projection"
' Add Team Stack Column
    Cells(1, lLastHTeamCol + 3).Value = ChrW(931) & " Stack"
' Add Team Stack Pos
    Cells(1, lLastHTeamCol + 4).Value = ChrW(931) & " Stack POS"
' Add 2nd Team Stack Column
    Cells(1, lLastHTeamCol + 5).Value = ChrW(931) & " Stack2"
' Add 2nd Team Stack Pos
    Cells(1, lLastHTeamCol + 6).Value = ChrW(931) & " Stack2 POS"
' Filter 0-1
    Cells(1, lLastHTeamCol + 7).Value = ChrW(931) & " Filter"
' Player 1 Filter
    Cells(1, lLastHTeamCol + 8).Value = ChrW(931) & " Player1"
' Player 2 Filter
    Cells(1, lLastHTeamCol + 9).Value = ChrW(931) & " Player2"
'
    With Range(Cells(2, lLastHTeamCol + 2), Cells(lLastRowDeDuped, lLastHTeamCol + 2))
        .FormulaR1C1 = "=SUM(RC" & lFirstHSortColumn2 & ":RC" & lLastHSortColumn2 & ")"
        Application.Calculate
        .Value = .Value
    End With
'
    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
'
    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
'
    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
'
    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
'
'-------------------------------------------------------------------------------------------------------------------------------
'
' 8) "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 + 7), Cells(lLastRowDeDuped, lLastHTeamCol + 7))
    End With
'
    With Range(Cells(2, lLastHTeamCol + 8), Cells(lLastRowDeDuped, lLastHTeamCol + 8))
    End With
'
    With Range(Cells(2, lLastHTeamCol + 9), Cells(lLastRowDeDuped, lLastHTeamCol + 9))
    End With
'
'-------------------------------------------------------------------------------------------------------------------------------
'
' 9) 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(Cells(2, lFirstHSortColumn), Cells(lLastRowDeDuped, lLastHSortColumn)).EntireColumn.Delete
    Range(Cells(2, lFirstHSortColumn + 1), Cells(lLastRowDeDuped, lFirstHTeamCol)).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
'
    Call OptimizeCode_End
'
    Debug.Print sOutput
    MsgBox sOutput, , "Output Report"
End Sub



Public Function ReDimPreserve(ArrayNameToPreserve, NewRowUbound, NewColumnUbound)
'
' Code inspired by Control Freak
'
' Redim & preserve 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 OldColumnUbound             As Long, OldRowUbound                As Long
    Dim NewArrayNameToPreserve()    As Variant
'
    ReDimPreserve = False
'
    If IsArray(ArrayNameToPreserve) Then                                                                    ' If the variable is an array then ...
        ReDim NewArrayNameToPreserve(1 To NewRowUbound + 1, 1 To NewColumnUbound + 1)                       '   Create a New 2D 1 based Array
        OldRowUbound = UBound(ArrayNameToPreserve, 1)                                                       '   Save row Ubound of original array
        OldColumnUbound = UBound(ArrayNameToPreserve, 2)                                                    '   Save column Ubound of original array
'
        For NewRow = LBound(ArrayNameToPreserve, 1) To NewRowUbound                                         '   Loop through rows of original array
            For NewColumn = LBound(ArrayNameToPreserve, 2) To NewColumnUbound                               '       Loop through columns of original array
                If OldRowUbound >= NewRow And OldColumnUbound >= NewColumn Then
                    NewArrayNameToPreserve(NewRow, NewColumn) = ArrayNameToPreserve(NewRow, NewColumn)      '               Append rows/columns to NewArrayNameToPreserve
                End If
            Next                                                                                            '       Loop back
        Next                                                                                                '   Loop back
'
        If IsArray(NewArrayNameToPreserve) Then ReDimPreserve = NewArrayNameToPreserve
    End If
End Function
```

You may have noticed that it yields about twice the unique combination results because it is now set up to just remove combinations based on the names.

Anything else you want, related to this thread?


----------



## johnnyL (Dec 6, 2022)

cspengel said:


> Code certainly looks cleaner! I ran a few tests. First with data in your workbook, then a second one removing some names on the "salary" sheet that are not used on the "worksheet".



BTW, this is the code that I mentioned that makes it so you don't need to remove extra data in the 'Salary' sheet:


```
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
'
    SalarySheetFullArray = names.Range("A2:" & _
            Split(Cells(names.Cells.Find("*", , xlFormulas, , xlByColumns, xlPrevious).Column).Address, "$")(1) & lLastSalaryRow)   '   Save all of the data from the 'Salary' aheet into 2D 1 based SalarySheetFullArray
'
    ReDim SalarySheetShortenedArray(1 To UBound(SalarySheetFullArray, 1), 1 To UBound(SalarySheetFullArray, 2)) ' Set 2D 1 based SalarySheetShortenedArray to the same size as SalarySheetFullArray
'
    currow = 0                                                                                                      ' Initialize currow
'
    For UniqueArrayRow = 1 To UBound(UniqueWorksheetNamesArray, 1)                                                  ' Loop through the rows of UniqueWorksheetNamesArray
        For ArrayRow = 1 To UBound(SalarySheetFullArray, 1)                                                         '   Loop through the rows of SalarySheetFullArray
            If UniqueWorksheetNamesArray(UniqueArrayRow, 1) = SalarySheetFullArray(ArrayRow, 1) Then                '       If the name from UniqueWorksheetNamesArray is found in SalarySheetFullArray then ...
                currow = currow + 1                                                                                 '           Increment currow
'
                For lColumnIndex = 1 To UBound(SalarySheetFullArray, 2)                                             '           Loop through the columns of SalarySheetFullArray
                    SalarySheetShortenedArray(currow, lColumnIndex) = SalarySheetFullArray(ArrayRow, lColumnIndex)  '               Save the values to SalarySheetShortenedArray
                Next                                                                                                '           Loop back
            End If
        Next                                                                                                        '   Loop back
    Next                                                                                                            ' Loop back
'
    SalarySheetShortenedArray = Application.Transpose(SalarySheetShortenedArray)                                    ' Transpose SalarySheetShortenedArray so we can correct the size (row count)
'
    ReDim Preserve SalarySheetShortenedArray(1 To UBound(SalarySheetFullArray, 2), 1 To currow)                     ' Set the row count to actual used rows
'
    SalarySheetShortenedArray = Application.Transpose(SalarySheetShortenedArray)                                    ' Transpose back the SalarySheetShortenedArray
```

It creates an array called UniqueWorksheetNamesArray by saving the unique names from the 'Worksheet'.
It then creates an array called SalarySheetFullArray to store all of the data from the 'Salary' sheet.
It then creates an array called SalarySheetShortenedArray by looking at the unique names in UniqueWorksheetNamesArray, finding the matching name in SalarySheetFullArray, then it saves that name and data for that name into SalarySheetShortenedArray.

That allows you to use the SalarySheetShortenedArray instead of the entire 'Salary' sheet of data.


----------



## cspengel (Dec 6, 2022)

johnnyL said:


> Thank you for testing & pointing out the flaw. Code from post #56 has been corrected:
> 
> 
> ```
> ...


You've been more than enough help,  and this is just what i need thank you for your time!  Couldn't have done it without ya 🙂


----------



## johnnyL (Dec 6, 2022)

cspengel said:


> It was running for a bit and then just received an error on this code regarding object defined.
> 
> 
> ```
> ...


The error you received there is probably from too many combinations ie. >1048576 trying to be written to the sheet.

I have an idea that may work, but I have to think about it.


That other error you previously mentioned that you encountered ( error 45x or whatever it was that mentioned something about 'Let'), I encountered that today when I added a name to the 'Worksheet' that wasn't in the 'Salary' sheet. I haven't checked, but I thought your 'Section 1' addressed that issue?


----------



## cspengel (Dec 6, 2022)

johnnyL said:


> The error you received there is probably from too many combinations ie. >1048576 trying to be written to the sheet.
> 
> I have an idea that may work, but I have to think about it.
> 
> ...


Yeah, that first error your probably right. I think I copied that data directly from the post I made and it contained like 3 million combinations. 

It'd be nice to get over that million mark, but I can certainly make what we have work. 

As for the let Error, I never ran into that issue before your code. A pop-up always popped up and displayed names missing, but on yours it just gives the error. I'll try and look more at it


----------



## cspengel (Nov 25, 2022)

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



```
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
```


----------



## cspengel (Dec 6, 2022)

So I redeclared varK As variant.

changed this:


```
If oSD.Count <> 0 Then
        For lIndex = LBound(oSD.keys) To UBound(oSD.keys)
            sMissingSalary = sMissingSalary & ", " & oSD.keys(lIndex)
        Next
```

Back to this


```
If oSD.Count <> 0 Then
        varK = oSD.keys
        For lIndex = LBound(varK) To UBound(varK)
            sMissingSalary = sMissingSalary & ", " & varK(lIndex)
        Next
```

and the error goes away and popup box comes back.


----------



## johnnyL (Dec 6, 2022)

I'll make a note of that, I don't understand the difference, but it is noted.


----------



## cspengel (Dec 6, 2022)

johnnyL said:


> I'll make a note of that, I don't understand the difference, but it is noted.


Well I also changed your call to Optimize end as it doesn't appear to direct to to End the sub.

Changed


```
MsgBox sOutput
        Debug.Print sOutput
Call OptimizeCode_End
```


To

```
MsgBox sOutput
        Debug.Print sOutput
'
        GoTo End_Sub
```


And re-added to the bottom
	
	
	
	
	
	



```
End_Sub:
    Call OptimizeCode_End
   
End Sub
```

Maybe that did it.


----------



## johnnyL (Dec 6, 2022)

No, that didn't do it, but I made a note of that also. Good catch! Anything else I messed up?


----------



## cspengel (Dec 6, 2022)

johnnyL said:


> No, that didn't do it, but I made a note of that also. Good catch! Anything else I messed up?


Haha no not that I can tell. Runs great. Thank you!


----------



## johnnyL (Dec 6, 2022)

johnnyL said:


> The error you received there is probably from too many combinations ie. >1048576 trying to be written to the sheet.
> 
> I have an idea that may work, but I have to think about it.


Ok, I have most of it Pseudocoded, After I get some sleep I will try to see if it works when it is actually coded.


----------



## cspengel (Dec 7, 2022)

Sweet!! Thank you


johnnyL said:


> Ok, I have most of it Pseudocoded, After I get some sleep I will try to see if it works when it is actually coded


----------



## johnnyL (Dec 8, 2022)

To give you something to chew on while I mess with a lil bit more of the 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 NameCombosV11()
    'https://www.mrexcel.com/forum/excel-questions/1106189-all-combinations-multiple-columns-without-duplicates.html
'
    Dim bFoundSalary                    As Boolean
    Dim bShowError                      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 ColumnNumber                    As Long
    Dim currow                          As Long
    Dim firstrow                        As Long, lLastRow                       As Long
    Dim lColumnIndex                    As Long
    Dim lFirstHSortColumn               As Long, lFirstHSortColumn2             As Long
    Dim lFirstHTeamCol                  As Long, lLastHTeamCol                  As Long
    Dim lFirstWriteColumn               As Long, lLastWriteColumn               As Long
    Dim lIndex                          As Long
    Dim lIterationCount                 As Long, lLastIteration                 As Long
    Dim lLastColumn                     As Long
    Dim lLastHSortColumn                As Long, lLastHSortColumn2              As Long
    Dim lLastRowDeDuped                 As Long
    Dim lLastSalaryRow                  As Long
    Dim lLastUsedColumn                 As Long
    Dim lRowIndex                       As Long
    Dim lWriteColumn                    As Long, lWriteRow                      As Long
    Dim MaxSalaryAllowed                As Long
    Dim SubArrayNumber                  As Long
    Dim SubArrayRow                     As Long
    Dim SubArrays                       As Long
    Dim UniqueArrayRow                  As Long
    Dim x                               As Long
    Dim oSD                             As Object
    Dim cel                             As Range
    Dim rngDataBlock                    As Range
    Dim rngReplace                      As Range, rngReplace2                   As Range, rngReplace3                   As Range
    Dim rngSortRange                    As Range
    Dim SortRowRange                    As Range
    Dim WorksheetNameRange              As Range
    Dim Delimiter                       As String
    Dim oSD_KeyString                   As String
    Dim sErrorMsg                       As String
    Dim sMissingSalary                  As String
    Dim sOutput                         As String
    Dim arrOut()                        As Variant
    Dim aryDeDupe                       As Variant
    Dim aryNames                        As Variant
    Dim JaggedArray()                   As Variant
    Dim keysArray                       As Variant
    Dim NoDupeRowArray()                As Variant, NoDupeRowShortenedArray()   As Variant
    Dim NoDupeSortedRowsArray()         As Variant
    Dim SalaryCalculationArray()        As Variant
    Dim SalarySheetFullArray            As Variant, SalarySheetShortenedArray() As Variant
    Dim TempArray                       As Variant
    Dim UniqueSortedRowsArray           As Variant, UniqueUnSortedRowsArray()   As Variant
    Dim UniqueWorksheetNamesArray       As Variant
    Dim varK                            As Variant
    Dim WorksheetArray                  As Variant
    Dim WorksheetColumnArray()          As Variant
    Dim names                           As Worksheet
    Dim wks                             As Worksheet
    Dim wksData                         As Worksheet
'
    Const MaxRowsPerSubArray            As Long = 500000                                                                        ' <--- Set the MaxRowsPerSubArray
'
'-------------------------------------------------------------------------------------------------------------------------------
'
    MaxSalaryAllowed = 60000                                                                                                    ' <--- set this value to what you want
'
    Call OptimizeCode_Begin
'
    Set wksData = ThisWorkbook.Sheets("Worksheet")
    Set names = Sheets("Salary")
'
'-------------------------------------------------------------------------------------------------------------------------------
'
' 1) Take all the names entered on the "Worksheet" (A2:Ix) sheet and check to see if all of those names also have a salary listed on the "Salary" sheet.
'    If any of the names from "Worksheet" are not on the "Salary" sheet, it ends Sub. If all the names are on the salary sheet and there are corresponding
'    salaries for each of those names, a pop up box will appear letting you know how many combinations to expect.
'
    'Check for salary worksheet
    For Each wks In ThisWorkbook.Worksheets
        If wks.Name = "Salary" Then bFoundSalary = True
    Next
'
    If Not bFoundSalary Then
        MsgBox "The workbook must contain a worksheet named 'Salary' with data starting in row 2 " & _
            "that consists of column A containing each name in the name/column layout worksheet " & _
            "and column B containng their salary."
'
        GoTo End_Sub
    End If
'
    'Make sure each name has a corresponding salary entry
    'Initialize the scripting dictionary
    Set oSD = CreateObject("Scripting.Dictionary")
    oSD.CompareMode = vbTextCompare
'
    'Inventory names on the main worksheet
    For Each cel In ActiveSheet.Range("A1").CurrentRegion.Offset(1, 0)
        cel.Value = Trim(cel.Value)
'
        If cel.Value <> vbNullString Then
            oSD.Item(cel.Value) = oSD.Item(cel.Value) + 1
        End If
    Next
'
    'Remove names on the Salary worksheet
    With Worksheets("Salary")
        For Each cel In .Range("A2:A" & .Cells(Rows.Count, 1).End(xlUp).Row)
            cel.Value = Trim(cel.Value)
'
            If oSD.Exists(cel.Value) Then
                oSD.Remove cel.Value
            End If
        Next
    End With
'
    'Any names not accounted for?
    If oSD.Count <> 0 Then
        varK = oSD.keys
'
        For lIndex = LBound(varK) To UBound(varK)
            sMissingSalary = sMissingSalary & ", " & varK(lIndex)
        Next
'
        sMissingSalary = Mid(sMissingSalary, 3)
'
        sOutput = "The following names on the main worksheet do not have a corresponding entry on the 'Salary' worksheet." & vbLf & vbLf & sMissingSalary
'
        MsgBox sOutput
        Debug.Print sOutput
'
        GoTo End_Sub
    End If
'
    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
'
    lFirstWriteColumn = lLastColumn + 2
    lLastWriteColumn = (2 * lLastColumn) + 1
'
    Select Case MsgBox("Process a " & lLastColumn & " column table with " & _
        lLastIteration & " possible combinations?" & vbLf & vbLf & _
        "WARNING: Columns right of the input range will be erased before continuing.", vbOKCancel + vbExclamation + _
        vbDefaultButton2, "Process table?")
'
        Case vbCancel
            GoTo End_Sub
    End Select
'
'-------------------------------------------------------------------------------------------------------------------------------
'
' 2) Clear all columns to the right of Column I on the "Worksheet" sheet. Copy headers from A1:I1 on the "Worksheet" sheet to K1:S1 on the "Worksheet" sheet.
'    Add header "ComboID" to T1 on the "Worksheet" sheet. Create the combinations & if there are no duplicate names in the same combination row then write the
'    combination to K row#:S row# on the "Worksheet" sheet & write lIterationCount to T row# on the "Worksheet" sheet.
'
    dteStart = Now()
    StartTime = Now()
'
    Application.StatusBar = "Step 1 of 4 Calculating name combinations & saving combinations with no duplicate names in same combination ..."
    DoEvents
'
    'Clear all columns right of input range
    If lLastUsedColumn > lLastColumn Then
        Range(Cells(1, lLastColumn + 1), Cells(1, lLastUsedColumn)).EntireColumn.ClearContents
    End If
'
' Save Worksheet data into 2D 1 based WorksheetArray
    Set WorksheetNameRange = wksData.Range("A2:" & Split(Cells(1, lLastColumn).Address, "$")(1) & wksData.Range("A1").CurrentRegion.Find("*", , xlFormulas, , xlByRows, xlPrevious).Row)
    WorksheetArray = WorksheetNameRange
'
    ReDim NoDupeRowArray(1 To lLastIteration, 1 To lLastColumn + 1)
'
    Cells(1, lLastWriteColumn + 1).Value = "ComboID"
'
    'Add Output Header
    Range(Cells(1, 1), Cells(1, lLastColumn)).Copy Destination:=Cells(1, lFirstWriteColumn)
'
' Load data from 'Worksheet', each column of data will be loaded into a separate array
    ReDim WorksheetColumnArray(1 To lLastColumn)                                                        ' Set the # of arrays in 'jagged' array WorksheetColumnArray
'
    For ColumnNumber = 1 To lLastColumn                                                                 ' Loop through the columns of 'Worksheet'
        lLastRow = Cells(Rows.Count, ColumnNumber).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(ColumnNumber) = 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(ColumnNumber)(ArrayRow, 1) = WorksheetArray(ArrayRow, ColumnNumber)    '       Save the data to WorksheetColumnArray()
        Next                                                                                            '   Loop back
    Next                                                                                                ' Loop back
'
    'Start checking combinations
    lIterationCount = 0                                                                                 ' Reset lIterationCount
    lWriteRow = 0                                                                                       ' Reset lWriteRow
'
    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
'
' Initialize the scripting dictionary
                                        Set oSD = CreateObject("Scripting.Dictionary")
                                        oSD.CompareMode = vbTextCompare
'
' Check for duplicates in same row before saving to array
' Load names into scripting dictionary
                                        For x = 1 To 1                                                  '                                   Set up 'Fake loop' to allow exiting
                                            If Not oSD.Exists(WorksheetColumnArray(9)(ColumnI_Row, 1)) Then '                                   If name not previously seen in this row then ...
                                                oSD.Add WorksheetColumnArray(9)(ColumnI_Row, 1), ""     '                                           Save the name to the dictionary row
                                            Else                                                        '                                       Else ...
                                                Exit For                                                '                                           Exit this 'Fake loop'
                                            End If
'
                                            If Not oSD.Exists(WorksheetColumnArray(8)(ColumnH_Row, 1)) Then '                                   Same as previous /\ /\ /\
                                                oSD.Add WorksheetColumnArray(8)(ColumnH_Row, 1), ""
                                            Else
                                                Exit For
                                            End If
'
                                            If Not oSD.Exists(WorksheetColumnArray(7)(ColumnG_Row, 1)) Then '                                   Same as previous /\ /\ /\
                                                oSD.Add WorksheetColumnArray(7)(ColumnG_Row, 1), ""
                                            Else
                                                Exit For
                                            End If
'
                                            If Not oSD.Exists(WorksheetColumnArray(6)(ColumnF_Row, 1)) Then '                                   Same as previous /\ /\ /\
                                                oSD.Add WorksheetColumnArray(6)(ColumnF_Row, 1), ""
                                            Else
                                                Exit For
                                            End If
'
                                            If Not oSD.Exists(WorksheetColumnArray(5)(ColumnE_Row, 1)) Then '                                   Same as previous /\ /\ /\
                                                oSD.Add WorksheetColumnArray(5)(ColumnE_Row, 1), ""
                                            Else
                                                Exit For
                                            End If
'
                                            If Not oSD.Exists(WorksheetColumnArray(4)(ColumnD_Row, 1)) Then '                                   Same as previous /\ /\ /\
                                                oSD.Add WorksheetColumnArray(4)(ColumnD_Row, 1), ""
                                            Else
                                                Exit For
                                            End If
'
                                            If Not oSD.Exists(WorksheetColumnArray(3)(ColumnC_Row, 1)) Then '                                   Same as previous /\ /\ /\
                                                oSD.Add WorksheetColumnArray(3)(ColumnC_Row, 1), ""
                                            Else
                                                Exit For
                                            End If
'
                                            If Not oSD.Exists(WorksheetColumnArray(2)(ColumnB_Row, 1)) Then '                                   Same as previous /\ /\ /\
                                                oSD.Add WorksheetColumnArray(2)(ColumnB_Row, 1), ""
                                            Else
                                                Exit For
                                            End If
'
                                            If Not oSD.Exists(WorksheetColumnArray(1)(ColumnA_Row, 1)) Then _
                                                    oSD.Add WorksheetColumnArray(1)(ColumnA_Row, 1), "" '                                       If name not previously seen in this row then ...
'                                                                                                       '                                               Save the name to the dictionary row
                                        Next                                                            '                                   Exit 'Fake loop'
'
                                        If UBound(oSD.keys) + 1 = lLastColumn Then                      '                                   If no duplicates found in row then ...
' The current row had names and no duplicates
'
' Point to the next blank row
                                            lWriteRow = lWriteRow + 1                                               '                           Increment lWriteRow
'
                                            NoDupeRowArray(lWriteRow, 1) = WorksheetColumnArray(1)(ColumnA_Row, 1)  '                           Save name from column A to NoDupeRowArray
                                            NoDupeRowArray(lWriteRow, 2) = WorksheetColumnArray(2)(ColumnB_Row, 1)  '                           Save name from column B to NoDupeRowArray
                                            NoDupeRowArray(lWriteRow, 3) = WorksheetColumnArray(3)(ColumnC_Row, 1)  '                           Save name from column C to NoDupeRowArray
                                            NoDupeRowArray(lWriteRow, 4) = WorksheetColumnArray(4)(ColumnD_Row, 1)  '                           Save name from column D to NoDupeRowArray
                                            NoDupeRowArray(lWriteRow, 5) = WorksheetColumnArray(5)(ColumnE_Row, 1)  '                           Save name from column E to NoDupeRowArray
                                            NoDupeRowArray(lWriteRow, 6) = WorksheetColumnArray(6)(ColumnF_Row, 1)  '                           Save name from column F to NoDupeRowArray
                                            NoDupeRowArray(lWriteRow, 7) = WorksheetColumnArray(7)(ColumnG_Row, 1)  '                           Save name from column G to NoDupeRowArray
                                            NoDupeRowArray(lWriteRow, 8) = WorksheetColumnArray(8)(ColumnH_Row, 1)  '                           Save name from column H to NoDupeRowArray
                                            NoDupeRowArray(lWriteRow, 9) = WorksheetColumnArray(9)(ColumnI_Row, 1)  '                           Save name from column I to NoDupeRowArray
'
                                            NoDupeRowArray(lWriteRow, lLastColumn + 1) = lIterationCount    '                                   Save lIterationCount to NoDupeRowArray
                                        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
'
    NoDupeRowArray = ReDimPreserve(NoDupeRowArray, lWriteRow, lLastColumn + 1)                          ' Resize NoDupeRowArray to correct the actual rows used in the array
'
' Write current combination rows to sheet if combinations don't exceed MaxRowsPerSubArray
    If UBound(NoDupeRowArray, 1) < MaxRowsPerSubArray Then                                              ' If the total # of combinations saved < MaxRowsPerSubArray then ...
        wksData.Cells(2, lLastColumn + 2).Resize(UBound(NoDupeRowArray, 1), _
                UBound(NoDupeRowArray, 2)) = NoDupeRowArray                                             '   Display NoDupeRowArray to 'Worksheet'
'
        Debug.Print "Create all combinations & remove rows with duplicate entries in the same row completed " & _
                "in " & Format(Now() - StartTime, "hh:mm:ss")                                           '   Display elapsed time for this process to the 'Immediate' window (CTRL+G) in VBE
'
        GoTo Continue                                                                                   '
    Else                                                                                                ' Else ...
        Application.StatusBar = "Step 2 of 4 Sorting all combinations by rows & removing rows with duplicate entries previously seen ..."
        DoEvents
'
        SubArrays = Int((UBound(NoDupeRowArray, 1) - 1) / MaxRowsPerSubArray) + 1                       ' number of SubArrays needed
'
        ReDim JaggedArray(1 To SubArrays)                                                               ' Set # of SubArrays in JaggedArray
'
        currow = 0                                                                                      ' Reset currow
'
        For SubArrayNumber = 1 To SubArrays                                                             ' Loop through SubArrays
            ReDim arrOut(1 To MaxRowsPerSubArray, 1 To UBound(NoDupeRowArray, 2))                       '   Reset the arrOut
'
            For SubArrayRow = 1 To MaxRowsPerSubArray                                                   '   Loop through rows of arrOut
                currow = currow + 1                                                                     '       Increment currow, this is the row of the NoDupeRowArray
'
                If currow > UBound(NoDupeRowArray, 1) Then Exit For                                     '       If all of the rows have been processed then exit this For loop
'
                For ArrayColumn = 1 To UBound(NoDupeRowArray, 2)                                        '       Loop through columns of NoDupeRowArray
                    arrOut(SubArrayRow, ArrayColumn) = NoDupeRowArray(currow, ArrayColumn)              '           Save column value into arrOut
                Next                                                                                    '       Loop back
            Next                                                                                        '   Loop back
'
            JaggedArray(SubArrayNumber) = arrOut                                                        '   Save the arrOut to the JaggedArray
        Next                                                                                            ' Loop back
'
' At this point, all of the MaxRowsPerSubArray row subArrays have been loaded into the JaggedArray
'
        For SubArrayNumber = 1 To SubArrays                                                             ' Loop through SubArrays
            ActiveSheet.Range("K2").Resize(UBound(JaggedArray(SubArrayNumber), 1), _
                    UBound(JaggedArray(SubArrayNumber), 2)) = JaggedArray(SubArrayNumber)               '   Write the subArray to the sheet for sorting
'
' Sort each row
            ActiveSheet.Sort.SortFields.Clear
'
            lLastRow = Cells(Rows.Count, lFirstWriteColumn).End(xlUp).Row                               '   Get lLastRow
'
            Set rngSortRange = Range(Cells(2, lFirstWriteColumn), _
                    Cells(lLastRow, lLastWriteColumn + 1))                                              '   Set the Range to be sorted
'
            For Each SortRowRange In rngSortRange.Rows                                                  '   Loop through each row of the range to be sorted
                SortRowRange.Sort Key1:=SortRowRange.Cells(1, 1), Order1:=xlAscending, _
                        Header:=xlNo, Orientation:=xlSortRows                                           '       Sort each row alphabetically
            Next                                                                                        '   Loop back
'
' Load the sorted data back into the subArray
            JaggedArray(SubArrayNumber) = ActiveSheet.Range("K2").Resize(UBound(JaggedArray(SubArrayNumber), 1), _
                    UBound(JaggedArray(SubArrayNumber), 2))                                         '
'
            ActiveSheet.Range("K2").Resize(UBound(JaggedArray(SubArrayNumber), 1), _
                    UBound(JaggedArray(SubArrayNumber), 2)).ClearContents                               '   Clear the sort range
        Next                                                                                            ' Loop back
'
' Join all of the sorted subArrays back into 1 large array
        ReDim NoDupeSortedRowsArray(1 To UBound(NoDupeRowArray, 1), 1 To UBound(NoDupeRowArray, 2) - 1) '
'
        currow = 0                                                                                      ' Reset currow
'
        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
                currow = currow + 1                                                                     '       Increment currow, this is the row of the NoDupeSortedRowsArray
'
                If currow > UBound(NoDupeSortedRowsArray, 1) Then Exit For                              '       If all sorted rows have been written to NoDupeSortedRowsArray then exit this loop
'
                For ArrayColumn = 1 To UBound(NoDupeSortedRowsArray, 2)                                 '       Loop through columns of NoDupeSortedRowsArray
                    NoDupeSortedRowsArray(currow, ArrayColumn) = _
                            JaggedArray(SubArrayNumber)(SubArrayRow, ArrayColumn)                       '           Save column value into NoDupeSortedRowsArray
                Next                                                                                    '       Loop back
            Next                                                                                        '   Loop back
        Next                                                                                            ' Loop back
'
' At this point, all of the MaxRowsPerSubArray sorted row subArrays have been loaded into the NoDupeSortedRowsArray, last column is now first column though ;)
'
' Time to eliminate the duplicate rows in NoDupeSortedRowsArray
'
        ReDim keysArray(1 To UBound(NoDupeSortedRowsArray, 1), 1 To 1)                                  ' Set # of rows/columns of keysArray
'
' Combine each name in each row, separated by a Delimiter, to oSD_KeyString
        For ArrayRow = LBound(NoDupeSortedRowsArray, 1) To UBound(NoDupeSortedRowsArray, 1)             ' Loop through rows of NoDupeSortedRowsArray
            oSD_KeyString = ""                                                                          '   Erase 'oSD_KeyString'
            Delimiter = ""                                                                              '   Erase 'Delimiter' of NoDupeSortedRowsArray
'
            For ArrayColumn = LBound(NoDupeSortedRowsArray, 2) + 1 To UBound(NoDupeSortedRowsArray, 2)  '   Loop through name columns of NoDupeSortedRowsArray
                oSD_KeyString = oSD_KeyString & Delimiter & NoDupeSortedRowsArray(ArrayRow, ArrayColumn)    '       Save names from NoDupeSortedRowsArray row, separated by Delimiter, into oSD_KeyString
''            Delimiter = Chr(0)
                Delimiter = Chr(2)
            Next                                                                                        '   Loop back
'
            keysArray(ArrayRow, 1) = " " & Delimiter & oSD_KeyString                                    '   Save oSD_KeyString to keysArray
            oSD(oSD_KeyString) = True
        Next                                                                                            ' Loop back
'
        ReDim UniqueSortedRowsArray(LBound(NoDupeSortedRowsArray, 1) To oSD.Count + (LBound(NoDupeSortedRowsArray, 1) - 1), _
                LBound(NoDupeSortedRowsArray, 2) To UBound(NoDupeSortedRowsArray, 2) + 1)                 ' Set # of rows/columns of UniqueSortedRowsArray
'
'-------------------------------------------------------------------------------------------------------
'
' Copy each unique row to UniqueSortedRowsArray
        currow = LBound(NoDupeSortedRowsArray, 1) - 1                                                   ' Initialize currow
'
        For ArrayRow = LBound(NoDupeSortedRowsArray, 1) To UBound(NoDupeSortedRowsArray, 1)             ' Loop through rows of NoDupeSortedRowsArray
            If Not oSD.Exists(keysArray(ArrayRow, 1)) Then                                              '
                oSD.Add keysArray(ArrayRow, 1), ""                                                      '
'
                currow = currow + 1                                                                     '       Increment currow
'
                UniqueSortedRowsArray(currow, UBound(UniqueSortedRowsArray, 2)) = _
                        NoDupeSortedRowsArray(ArrayRow, 1)                                              '       Save the combination # to UniqueSortedRowsArray
'
                For ArrayColumn = LBound(NoDupeSortedRowsArray, 2) + 1 To UBound(NoDupeSortedRowsArray, 2)  '       Loop through columns of NoDupeSortedRowsArray
                    UniqueSortedRowsArray(currow, ArrayColumn - 1) = _
                            NoDupeSortedRowsArray(ArrayRow, ArrayColumn)                                '           Copy value to UniqueSortedRowsArray
                Next                                                                                    '       Loop back
'
                oSD(keysArray(ArrayRow, 1)) = False                                                     '       Flag this row as not unique      flag this key as copied
            End If
        Next                                                                                            ' Loop back
'
        UniqueSortedRowsArray = ReDimPreserve(UniqueSortedRowsArray, currow, UBound(UniqueSortedRowsArray, 2))  ' Correct the number of rows of UniqueSortedRowsArray
    End If
'
' At this point, NoDupeSortedRowsArrayUnique has been created with sorted rows with no duplicate rows & the ComboID has been added back
'
' Now we need to match the ComboID in UniqueSortedRowsArray to the ComboID in NoDupeRowArray so we can put the names for that row back to the original order
'
    ReDim UniqueUnSortedRowsArray(1 To UBound(UniqueSortedRowsArray, 1), 1 To UBound(UniqueSortedRowsArray, 2)) ' Set the # of rows/columns for UniqueUnSortedRowsArray
    ReDim SalaryCalculationArray(1 To UBound(UniqueSortedRowsArray, 1), 1 To UBound(UniqueSortedRowsArray, 2)) ' Set the # of rows/columns for SalaryArray
'
    currow = 1                                                                                          ' Increment currow
'
    For ArrayRow = LBound(NoDupeRowArray, 1) To UBound(NoDupeRowArray, 1)                               ' Loop through rows of NoDupeRowArray
        If currow > UBound(UniqueUnSortedRowsArray, 1) Then Exit For                                    '   If we have processed all rows then exit this For loop
'
        If UniqueSortedRowsArray(currow, UBound(UniqueSortedRowsArray, 2)) = _
                NoDupeRowArray(ArrayRow, UBound(NoDupeRowArray, 2)) Then                                '   If we found matching ComboID's then ...
'
''            For ArrayColumn = LBound(NoDupeRowArray, 2) To UBound(NoDupeRowArray, 2)                    '       Loop through the columns of NoDupeRowArray
''                UniqueUnSortedRowsArray(currow, ArrayColumn) = NoDupeRowArray(ArrayRow, ArrayColumn)    '           Save the value from the row/column to UniqueUnSortedRowsArray
''            Next                                                                                        '       Loop back
            For ArrayColumn = LBound(NoDupeRowArray, 2) To UBound(NoDupeRowArray, 2 - 1)                '       Loop through the columns of NoDupeRowArray except for the last column
                UniqueUnSortedRowsArray(currow, ArrayColumn) = NoDupeRowArray(ArrayRow, ArrayColumn)    '           Save the name from the row/column to UniqueUnSortedRowsArray
                SalaryCalculationArray(currow, ArrayColumn) = NoDupeRowArray(ArrayRow, ArrayColumn)     '           Save the name from the row/column to SalaryCalculationArray
            Next                                                                                        '       Loop back
'
            UniqueUnSortedRowsArray(currow, UBound(UniqueUnSortedRowsArray, 2)) = _
                    NoDupeRowArray(ArrayRow, UBound(NoDupeRowArray, 2))                                 '       Save the ComboID to UniqueUnSortedRowsArray
'
            currow = currow + 1                                                                         '       Increment currow
        End If
    Next                                                                                                ' Loop back
'
    wksData.Cells(2, lLastColumn + 2).Resize(UBound(UniqueUnSortedRowsArray, 1), _
            UBound(UniqueUnSortedRowsArray, 2)) = UniqueUnSortedRowsArray                               ' Display UniqueUnSortedRowsArray to 'Worksheet'
'
    Debug.Print "Create all combinations & remove rows with duplicate entries in the same row completed " & _
        "in " & Format(Now() - StartTime, "hh:mm:ss")                                                   ' Display elapsed time for this process to the 'Immediate' window (CTRL+G) in VBE
'






    lLastRow = Cells(Rows.Count, lFirstWriteColumn).End(xlUp).Row
'
    Range(Cells(1, lFirstWriteColumn), Cells(lLastRow, lLastWriteColumn)).Copy Destination:=Cells(1, lLastWriteColumn + 2) '' Rows for SALARY ... Copy K1:S & lLastRow to U1:AC & lLastRow
    lFirstHSortColumn = lLastWriteColumn + 2                                                                                ' 21 ie. column U
    lLastHSortColumn = Cells(1, Columns.Count).End(xlToLeft).Column                                                         ' 29 ie. column AC
'
    GoTo Salary_Code





'
'-------------------------------------------------------------------------------------------------------------------------------
'-------------------------------------------------------------------------------------------------------------------------------
'-------------------------------------------------------------------------------------------------------------------------------
'
' 4) Copy name combinations from columns K:S and pastes them in columns U:AC, AD:AL, AM:AU
'
Continue:
    StartTime = Now()
'
    Application.StatusBar = "Step 2 of 4 Sorting all combinations by rows & removing rows with duplicate entries previously seen ..."
    DoEvents
'
    '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) '' Rows for SALARY ... Copy K1:S & lLastRow to U1:AC & lLastRow
    lFirstHSortColumn = lLastWriteColumn + 2                                                                                ' 21 ie. column U
    lLastHSortColumn = Cells(1, Columns.Count).End(xlToLeft).Column                                                         ' 29 ie. column AC
'
'-------------------------------------------------------------------------------------------------------------------------------
'





' 6) Build an array from the combination names in columns K:S. States it excludes iteration # column. I am not sure what that is referencing.
'    May be the ComboID in column T. The duplicate combinations are then removed. Keep in mind Duplicates in ANY order are removed.
'    If the same players are used in a lineup, regardless of column, they are removed.
'
' Sort each row
    ActiveSheet.Sort.SortFields.Clear
'
    Set rngSortRange = Range(Cells(2, lFirstHSortColumn), Cells(lLastRow, lLastHSortColumn))
'
    For Each SortRowRange In rngSortRange.Rows
        SortRowRange.Sort Key1:=SortRowRange.Cells(1, 1), Order1:=xlAscending, Header:=xlNo, Orientation:=xlSortRows
    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
'
    ReDim aryDeDupe(0 To lLastHSortColumn - lFirstHSortColumn)
'
    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  ' *** This line reduces lines of data
    'Above line won't work unless there are parens around the Columns argument ????? ... This is normal behavior :)
'
Debug.Print "Sort all combinations by rows & remove rows with duplicate entries previously seen completed " & _
        "in " & Format(Now() - StartTime, "hh:mm:ss")                                                   ' Display elapsed time for this process to the 'Immediate' window (CTRL+G) in VBE
'
'-------------------------------------------------------------------------------------------------------------------------------
'
' 5) Replace copied names in column U:AC with the players respective salary data on "Salary" sheet. Column AV becomes "Salary" column and
'    the sum of columns U:AC is calculated. Max salary is declared at 60000. The data in A2:I26 is copied to the "Salary" sheet in cell G2:O26
'    before filter is applied. Autofilter is then applied to the range AV. If the value in AV is greater than 60000, the range K:BE for that row will be deleted.
'    The data copied to G2:O26 is then cut and pasted back to A2:I26 and autofilter is turned off.
'
       'Assumes the 'Salary' worksheet has names in the column A and salaries in column B starting in row 2
    'Replace HSort names with salary
'
Salary_Code:
'
    StartTime = Now()
'
    Application.StatusBar = "Step 3 of 4 Removing all combination rows with salaries > " & MaxSalaryAllowed & " ..."
    DoEvents
'
    With Worksheets("Salary") '''' SALARY
        lLastSalaryRow = .Cells(.Rows.Count, 1).End(xlUp).Row
    End With
'
    With CreateObject("scripting.dictionary")
        .CompareMode = vbTextCompare
'
        For Each cel In WorksheetNameRange                                                                          '   Loop through each cell in the WorksheetNameRange
            If cel <> "" Then                                                                                       '       If the cell is not blank then ...
                If Not .Exists(cel.Value) Then                                                                      '           If the value has not already been saved then ...
                    .Add cel.Value, cel.Value                                                                       '               Save the value
                End If
            End If
'
            UniqueWorksheetNamesArray = Application.Transpose(Array(.keys))                                         '       Transpose results to 2D 1 based UniqueWorksheetNamesArray
        Next                                                                                                        '   Loop back
    End With
'
    SalarySheetFullArray = names.Range("A2:" & _
            Split(Cells(names.Cells.Find("*", , xlFormulas, , xlByColumns, xlPrevious).Column).Address, "$")(1) & lLastSalaryRow)   '   Save all of the data from the 'Salary' aheet into 2D 1 based SalarySheetFullArray
'
    ReDim SalarySheetShortenedArray(1 To UBound(SalarySheetFullArray, 1), 1 To UBound(SalarySheetFullArray, 2)) ' Set 2D 1 based SalarySheetShortenedArray to the same size as SalarySheetFullArray
'
    currow = 0                                                                                                      ' Initialize currow
'
    For UniqueArrayRow = 1 To UBound(UniqueWorksheetNamesArray, 1)                                                  ' Loop through the rows of UniqueWorksheetNamesArray
        For ArrayRow = 1 To UBound(SalarySheetFullArray, 1)                                                         '   Loop through the rows of SalarySheetFullArray
            If UniqueWorksheetNamesArray(UniqueArrayRow, 1) = SalarySheetFullArray(ArrayRow, 1) Then                '       If the name from UniqueWorksheetNamesArray is found in SalarySheetFullArray then ...
                currow = currow + 1                                                                                 '           Increment currow
'
                For lColumnIndex = 1 To UBound(SalarySheetFullArray, 2)                                             '           Loop through the columns of SalarySheetFullArray
                    SalarySheetShortenedArray(currow, lColumnIndex) = SalarySheetFullArray(ArrayRow, lColumnIndex)  '               Save the values to SalarySheetShortenedArray
                Next                                                                                                '           Loop back
            End If
        Next                                                                                                        '   Loop back
    Next                                                                                                            ' Loop back
'
    SalarySheetShortenedArray = Application.Transpose(SalarySheetShortenedArray)                                    ' Transpose SalarySheetShortenedArray so we can correct the size (row count)
'
    ReDim Preserve SalarySheetShortenedArray(1 To UBound(SalarySheetFullArray, 2), 1 To currow)                     ' Set the row count to actual used rows
'
    SalarySheetShortenedArray = Application.Transpose(SalarySheetShortenedArray)                                    ' Transpose back the SalarySheetShortenedArray
'
    lLastRow = Cells(Rows.Count, lFirstWriteColumn).End(xlUp).Row
'
    Set rngReplace = Range(Cells(2, lFirstHSortColumn), Cells(lLastRow, lLastHSortColumn))
'
    For lRowIndex = 1 To UBound(SalarySheetShortenedArray, 1)
        rngReplace.Replace What:=SalarySheetShortenedArray(lRowIndex, 1), _
                Replacement:=SalarySheetShortenedArray(lRowIndex, 2), LookAt:=xlWhole, _
                SearchOrder:=xlByRows, MatchCase:=False, SearchFormat:=False, ReplaceFormat:=False
    Next
'
    lLastRowDeDuped = Cells(Rows.Count, lFirstWriteColumn).End(xlUp).Row
'
    lLastHTeamCol = Cells(1, Columns.Count).End(xlToLeft).Column
'
' 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
        Set rngDataBlock = .Range(.Cells(1, lLastHTeamCol + 1), .Cells(lLastRow, lLastHTeamCol + 1))
    End With
'
    With rngDataBlock
        .AutoFilter Field:=1, Criteria1:=">" & MaxSalaryAllowed
'
        On Error Resume Next
        .Range(Cells(2, lFirstWriteColumn), Cells(lLastRow, lLastHTeamCol + 9)).Delete Shift:=xlUp      '   This took almost 6 minutes :(
        On Error GoTo 0
    End With
'
' Turn off the Autofilter safely
    With wksData
        .AutoFilterMode = False
'
        If .FilterMode = True Then .ShowAllData
   End With
'
    wksData.Range("A2").Resize(UBound(WorksheetArray, 1), UBound(WorksheetArray, 2)) = WorksheetArray   ' Write original data back to wksData just in case it was deleted
'
Debug.Print "Remove all combinations with salaries > " & MaxSalaryAllowed & " completed " & _
        "in " & Format(Now() - StartTime, "hh:mm:ss")                                                   ' Display elapsed time for this process to the 'Immediate' window (CTRL+G) in VBE
'
'-------------------------------------------------------------------------------------------------------------------------------
'
' 7) The names copied over to AD:AL are replaced with the corresponding players projection on the "Salary" sheet. The names copied over to AM:AU are replaced
'    with the corresponding players team located on the "Salary" Sheet. 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.
'
    Application.StatusBar = "Step 4 of 4 Wrapping up ..."
    DoEvents
'
    lLastRow = Cells(Rows.Count, lFirstWriteColumn).End(xlUp).Row
'
    If lLastRow > 1 Then
        Range(Cells(1, lFirstWriteColumn), Cells(lLastRow, lLastWriteColumn)).Copy Destination:=Cells(1, lLastHSortColumn + 2) '' Rows for PROJECTION
'
        lLastHSortColumn2 = Cells(1, Columns.Count).End(xlToLeft).Column
'
        Range(Cells(1, lFirstWriteColumn), Cells(lLastRow, lLastWriteColumn)).Copy Destination:=Cells(1, lLastHSortColumn2 + 1) '' Rows for TEAM
'
        lLastRowDeDuped = Cells(Rows.Count, lFirstWriteColumn).End(xlUp).Row
'
        lFirstHSortColumn2 = lLastHSortColumn + 2
'
        lFirstHTeamCol = lLastHSortColumn2 + 1
'
        lLastHTeamCol = Cells(1, Columns.Count).End(xlToLeft).Column
'
        Set rngReplace2 = Range(Cells(2, lFirstHSortColumn2), Cells(lLastRow, lLastHSortColumn2))
        Set rngReplace3 = Range(Cells(2, lFirstHTeamCol), Cells(lLastRow, lLastHTeamCol))
'
        For lRowIndex = 1 To UBound(SalarySheetShortenedArray, 1)
'
'''''''''''''''''''''''''''''''''''''PROJECTION
            rngReplace2.Replace What:=SalarySheetShortenedArray(lRowIndex, 1), _
                Replacement:=SalarySheetShortenedArray(lRowIndex, 3), LookAt:=xlWhole, _
                SearchOrder:=xlByRows, MatchCase:=False, SearchFormat:=False, ReplaceFormat:=False
'
'
         '''''''''''''''''''''''''''''''''''''TEAM
            rngReplace3.Replace What:=SalarySheetShortenedArray(lRowIndex, 1), _
                Replacement:=SalarySheetShortenedArray(lRowIndex, 4), LookAt:=xlWhole, _
                SearchOrder:=xlByRows, MatchCase:=False, SearchFormat:=False, ReplaceFormat:=False
        Next
'
' Add Projection Column
        Cells(1, lLastHTeamCol + 2).Value = ChrW(931) & " Projection"
' Add Team Stack Column
        Cells(1, lLastHTeamCol + 3).Value = ChrW(931) & " Stack"
' Add Team Stack Pos
        Cells(1, lLastHTeamCol + 4).Value = ChrW(931) & " Stack POS"
' Add 2nd Team Stack Column
        Cells(1, lLastHTeamCol + 5).Value = ChrW(931) & " Stack2"
' Add 2nd Team Stack Pos
        Cells(1, lLastHTeamCol + 6).Value = ChrW(931) & " Stack2 POS"
' Filter 0-1
        Cells(1, lLastHTeamCol + 7).Value = ChrW(931) & " Filter"
' Player 1 Filter
        Cells(1, lLastHTeamCol + 8).Value = ChrW(931) & " Player1"
' Player 2 Filter
        Cells(1, lLastHTeamCol + 9).Value = ChrW(931) & " Player2"
'
        With Range(Cells(2, lLastHTeamCol + 2), Cells(lLastRowDeDuped, lLastHTeamCol + 2))
            .FormulaR1C1 = "=SUM(RC" & lFirstHSortColumn2 & ":RC" & lLastHSortColumn2 & ")"
            Application.Calculate
            .Value = .Value
        End With
'
        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
'
        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
'
        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
'
        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
'
'-------------------------------------------------------------------------------------------------------------------------------
'
' 8) "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 + 7), Cells(lLastRowDeDuped, lLastHTeamCol + 7))
        End With
'
        With Range(Cells(2, lLastHTeamCol + 8), Cells(lLastRowDeDuped, lLastHTeamCol + 8))
        End With
'
        With Range(Cells(2, lLastHTeamCol + 9), Cells(lLastRowDeDuped, lLastHTeamCol + 9))
        End With
    Else
        MsgBox "No rows qualified for further testing."
        lFirstHTeamCol = Cells(1, Columns.Count).End(xlToLeft).Column
    End If
'
'-------------------------------------------------------------------------------------------------------------------------------
'
' 9) 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(Cells(2, lFirstHSortColumn), Cells(lLastRowDeDuped, lLastHSortColumn)).EntireColumn.Delete
    Range(Cells(2, lFirstHSortColumn + 1), Cells(lLastRowDeDuped, lFirstHTeamCol)).EntireColumn.Delete
'
    ActiveSheet.UsedRange.Columns.AutoFit
'
    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."
'
End_Sub:
    Call OptimizeCode_End
'
    Debug.Print sOutput
    MsgBox sOutput, , "Output Report"
End Sub



Public Function ReDimPreserve(ArrayNameToResize, NewRowUbound, NewColumnUbound)
'
' Code inspired by Control Freak
'
' Redim & preserve 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)
        OldColumnLbound = LBound(ArrayNameToResize, 2)
'
        ReDim NewResizedArray(OldRowLbound To NewRowUbound, OldColumnLbound To NewColumnUbound)             '   Create a New 2D Array
'
        OldRowUbound = UBound(ArrayNameToResize, 1)                                                         '   Save row Ubound of original array
        OldColumnUbound = UBound(ArrayNameToResize, 2)                                                      '   Save column Ubound of original array
'
''        For NewRow = LBound(ArrayNameToResize, 1) To NewRowUbound                                         '   Loop through rows of original array
''            For NewColumn = LBound(ArrayNameToResize, 2) To NewColumnUbound                               '       Loop through columns 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
'
        If IsArray(NewResizedArray) Then ReDimPreserve = NewResizedArray
    End If
End Function
```

That code should allow for more combinations.

I still am not done messing with the code, but that code should allow you to run more combinations than the previous versions.

Let me know how that version works for you.


----------



## johnnyL (Dec 8, 2022)

I have 2 areas that I still want to look into, the total combination creation section & the deletion of rows after the 'Sum' formula is applied for the salary section.


----------



## cspengel (Dec 9, 2022)

johnnyL said:


> I have 2 areas that I still want to look into, the total combination creation section & the deletion of rows after the 'Sum' formula is applied for the salary section.


Thanks for your work on this! I will give the newest code you supplied some tests tomorrow. 🙂


----------



## cspengel (Nov 25, 2022)

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



```
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
```


----------



## johnnyL (Dec 9, 2022)

Disregard Post #79, there is a mistake in the code. I will update it in a while.


----------



## johnnyL (Dec 10, 2022)

Here are the results from the latest code I came up with:


```
Create all combinations & remove rows with duplicate entries in the same row completed in 00:08:16
Sorting remaining combination rows alphabetically by row completed in 00:01:44
Removing duplicate sorted rows completed in 00:00:30
Remove all combinations with salaries > 60000 completed in 00:00:37
Wrapping up completed in 00:00:22
786240   possible combinations
60533    unique name combinations
60533    printed.

00:11:29 to process.
```

That is roughly 3x faster than the original code.

I think we can see the bottleneck of time is in the step to create all combinations & remove rows with duplicate entries in the same row.
All though that section is nearly 3x faster than the original code, it should not take that long & I will have to look into that further, if you want me to. I would think it could be done in under 1 minute if smartly coded.

If that can be achieved, that would put the total run time, for this test, under three minutes.

Anyways, here is the current state of the code I have come up with. Please read the comments so you can understand what it is doing.


```
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 NameCombosV12()
    '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 ColumnNumber                    As Long
    Dim currow                          As Long
    Dim firstrow                        As Long, lLastRow                       As Long
    Dim lColumnIndex                    As Long
    Dim lFirstHSortColumn               As Long, lFirstHSortColumn2             As Long
    Dim lFirstHTeamCol                  As Long, lLastHTeamCol                  As Long
    Dim lFirstWriteColumn               As Long, lLastWriteColumn               As Long
    Dim lIndex                          As Long
    Dim lIterationCount                 As Long, lLastIteration                 As Long
    Dim lLastColumn                     As Long
    Dim lLastHSortColumn                As Long, lLastHSortColumn2              As Long
    Dim lLastRowDeDuped                 As Long
    Dim lLastSalaryRow                  As Long
    Dim lLastUsedColumn                 As Long
    Dim lRowIndex                       As Long
    Dim lWriteColumn                    As Long, lWriteRow                      As Long
    Dim MaxSalaryAllowed                As Long
    Dim SubArrayNumber                  As Long
    Dim SubArrayRow                     As Long
    Dim SubArrays                       As Long
    Dim UniqueArrayRow                  As Long
    Dim x                               As Long
    Dim oSD                             As Object
    Dim cel                             As Range
    Dim rngDataBlock                    As Range
    Dim rngReplace                      As Range, rngReplace2                   As Range, rngReplace3                   As Range
    Dim rngSortRange                    As Range
    Dim SortRowRange                    As Range
    Dim WorksheetNameRange              As Range
    Dim Delimiter                       As String
    Dim oSD_KeyString                   As String
    Dim sErrorMsg                       As String
    Dim sMissingSalary                  As String
    Dim sOutput                         As String
    Dim arrOut()                        As Variant
    Dim aryDeDupe                       As Variant
    Dim aryNames                        As Variant
    Dim JaggedArray()                   As Variant
    Dim keysArray                       As Variant
    Dim NoDupeRowArray()                As Variant, NoDupeRowShortenedArray()   As Variant
    Dim NoDupeSortedRowsArray()         As Variant
    Dim SalaryCalculationArray          As Variant, SalaryCalcShortenedArray()  As Variant
    Dim SalarySheetFullArray            As Variant, SalarySheetShortenedArray() As Variant
    Dim TempArray                       As Variant
    Dim UniqueSortedRowsArray           As Variant, UniqueUnSortedRowsArray()   As Variant
    Dim UniqueWorksheetNamesArray       As Variant
    Dim varK                            As Variant
    Dim WorksheetArray                  As Variant
    Dim WorksheetColumnArray()          As Variant
    Dim names                           As Worksheet
    Dim wks                             As Worksheet
    Dim wksData                         As Worksheet
'
    Const MaxRowsPerSubArray            As Long = 500000                                                                        ' <--- Set the MaxRowsPerSubArray
    ComboID_Display = True                                                                                                      ' <--- Set this to True or False to see/not see the ComboID column
    MaxSalaryAllowed = 60000                                                                                                    ' <--- set this value to what you want
'
'-------------------------------------------------------------------------------------------------------------------------------
'
    Call OptimizeCode_Begin
'
    Set wksData = ThisWorkbook.Sheets("Worksheet")
    Set names = Sheets("Salary")
'
'-------------------------------------------------------------------------------------------------------------------------------
'
' 1) Take all the names entered on the "Worksheet" (A2:Ix) sheet and check to see if all of those names also have a salary listed on the "Salary" sheet.
'    If any of the names from "Worksheet" are not on the "Salary" sheet, it ends Sub. If all the names are on the salary sheet and there are corresponding
'    salaries for each of those names, a pop up box will appear letting you know how many combinations to expect.
'
    'Check for salary worksheet
    For Each wks In ThisWorkbook.Worksheets
        If wks.Name = "Salary" Then bFoundSalary = True
    Next
'
    If Not bFoundSalary Then
        MsgBox "The workbook must contain a worksheet named 'Salary' with data starting in row 2 " & _
            "that consists of column A containing each name in the name/column layout worksheet " & _
            "and column B containng their salary."
'
        GoTo End_Sub
    End If
'
    'Make sure each name has a corresponding salary entry
    'Initialize the scripting dictionary
    Set oSD = CreateObject("Scripting.Dictionary")
    oSD.CompareMode = vbTextCompare
'
    'Inventory names on the main worksheet
    For Each cel In ActiveSheet.Range("A1").CurrentRegion.Offset(1, 0)
        cel.Value = Trim(cel.Value)
'
        If cel.Value <> vbNullString Then
            oSD.Item(cel.Value) = oSD.Item(cel.Value) + 1
        End If
    Next
'
    'Remove names on the Salary worksheet
    With Worksheets("Salary")
        For Each cel In .Range("A2:A" & .Cells(Rows.Count, 1).End(xlUp).Row)
            cel.Value = Trim(cel.Value)
'
            If oSD.Exists(cel.Value) Then
                oSD.Remove cel.Value
            End If
        Next
    End With
'
    'Any names not accounted for?
    If oSD.Count <> 0 Then
        varK = oSD.keys
'
        For lIndex = LBound(varK) To UBound(varK)
            sMissingSalary = sMissingSalary & ", " & varK(lIndex)
        Next
'
        sMissingSalary = Mid(sMissingSalary, 3)
'
        sOutput = "The following names on the main worksheet do not have a corresponding entry on the 'Salary' worksheet." & vbLf & vbLf & sMissingSalary
'
        MsgBox sOutput
        Debug.Print sOutput
'
        GoTo End_Sub
    End If
'
    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
'
    lFirstWriteColumn = lLastColumn + 2
    lLastWriteColumn = (2 * lLastColumn) + 1
'
    Select Case MsgBox("Process a " & lLastColumn & " column table with " & _
        lLastIteration & " possible combinations?" & vbLf & vbLf & _
        "WARNING: Columns right of the input range will be erased before continuing.", vbOKCancel + vbExclamation + _
        vbDefaultButton2, "Process table?")
'
        Case vbCancel
            GoTo End_Sub
    End Select
'
'-------------------------------------------------------------------------------------------------------------------------------
'
' 2) Clear all columns to the right of Column I on the "Worksheet" sheet. Copy headers from A1:I1 on the "Worksheet" sheet to K1:S1 on the "Worksheet" sheet.
'    Add header "ComboID" to T1 on the "Worksheet" sheet. Create the combinations & if there are no duplicate names in the same combination row then write the
'    combination of names & lIterationCount to NoDupeRowArray.
'
    dteStart = Now()
    StartTime = Now()
'
    Application.StatusBar = "Step 1 of 5 ... Calculating name combinations & saving combinations with no duplicate names in same combination ..."
    DoEvents
'
    'Clear all columns right of input range
    If lLastUsedColumn > lLastColumn Then
        Range(Cells(1, lLastColumn + 1), Cells(1, lLastUsedColumn)).EntireColumn.ClearContents
    End If
'
' Save Worksheet data into 2D 1 based WorksheetArray
    Set WorksheetNameRange = wksData.Range("A2:" & Split(Cells(1, lLastColumn).Address, "$")(1) & _
            wksData.Range("A1").CurrentRegion.Find("*", , xlFormulas, , xlByRows, xlPrevious).Row)
    WorksheetArray = WorksheetNameRange
'
    ReDim NoDupeRowArray(1 To lLastIteration, 1 To lLastColumn + 1)                                         ' Set up NoDupeRowArray with rows = lLastIteration & columns 1 more than data range
'
    Cells(1, lLastWriteColumn + 1).Value = "ComboID"
'
    'Add Output Header
    Range(Cells(1, 1), Cells(1, lLastColumn)).Copy Destination:=Cells(1, lFirstWriteColumn)
'
' Load data from 'Worksheet', each column of data will be loaded into a separate array
    ReDim WorksheetColumnArray(1 To lLastColumn)                                                            ' Set the # of arrays in 'jagged' array WorksheetColumnArray
'
    For ColumnNumber = 1 To lLastColumn                                                                     ' Loop through the columns of 'Worksheet'
        lLastRow = Cells(Rows.Count, ColumnNumber).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(ColumnNumber) = 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(ColumnNumber)(ArrayRow, 1) = WorksheetArray(ArrayRow, ColumnNumber)        '       Save the data to WorksheetColumnArray()
        Next                                                                                                '   Loop back
    Next                                                                                                    ' Loop back
'
    'Start checking combinations
    lIterationCount = 0                                                                                     ' Reset lIterationCount
    lWriteRow = 0                                                                                           ' Reset lWriteRow
'
    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
'
' Initialize the scripting dictionary
                                        Set oSD = CreateObject("Scripting.Dictionary")
                                        oSD.CompareMode = vbTextCompare
'
' Check for duplicate names in same row before saving to array
' Load names into scripting dictionary
' Dictionary is used to check for unique names in each row, if all names are unique in the row then the names
'       are saved to NoDupeRowArray
                                        For x = 1 To 1                                                      '                                   Set up 'Fake loop' to allow exiting
                                            If Not oSD.Exists(WorksheetColumnArray(9)(ColumnI_Row, 1)) Then '                                   If name not previously seen in this row then ...
                                                oSD.Add WorksheetColumnArray(9)(ColumnI_Row, 1), ""         '                                           Save the name to the dictionary row
                                            Else                                                            '                                       Else ...
                                                Exit For                                                    '                                           Exit this 'Fake loop'
                                            End If
'
                                            If Not oSD.Exists(WorksheetColumnArray(8)(ColumnH_Row, 1)) Then '                                   Same as previous /\ /\ /\
                                                oSD.Add WorksheetColumnArray(8)(ColumnH_Row, 1), ""
                                            Else
                                                Exit For
                                            End If
'
                                            If Not oSD.Exists(WorksheetColumnArray(7)(ColumnG_Row, 1)) Then '                                   Same as previous /\ /\ /\
                                                oSD.Add WorksheetColumnArray(7)(ColumnG_Row, 1), ""
                                            Else
                                                Exit For
                                            End If
'
                                            If Not oSD.Exists(WorksheetColumnArray(6)(ColumnF_Row, 1)) Then '                                   Same as previous /\ /\ /\
                                                oSD.Add WorksheetColumnArray(6)(ColumnF_Row, 1), ""
                                            Else
                                                Exit For
                                            End If
'
                                            If Not oSD.Exists(WorksheetColumnArray(5)(ColumnE_Row, 1)) Then '                                   Same as previous /\ /\ /\
                                                oSD.Add WorksheetColumnArray(5)(ColumnE_Row, 1), ""
                                            Else
                                                Exit For
                                            End If
'
                                            If Not oSD.Exists(WorksheetColumnArray(4)(ColumnD_Row, 1)) Then '                                   Same as previous /\ /\ /\
                                                oSD.Add WorksheetColumnArray(4)(ColumnD_Row, 1), ""
                                            Else
                                                Exit For
                                            End If
'
                                            If Not oSD.Exists(WorksheetColumnArray(3)(ColumnC_Row, 1)) Then '                                   Same as previous /\ /\ /\
                                                oSD.Add WorksheetColumnArray(3)(ColumnC_Row, 1), ""
                                            Else
                                                Exit For
                                            End If
'
                                            If Not oSD.Exists(WorksheetColumnArray(2)(ColumnB_Row, 1)) Then '                                   Same as previous /\ /\ /\
                                                oSD.Add WorksheetColumnArray(2)(ColumnB_Row, 1), ""
                                            Else
                                                Exit For
                                            End If
'
                                            If Not oSD.Exists(WorksheetColumnArray(1)(ColumnA_Row, 1)) Then _
                                                    oSD.Add WorksheetColumnArray(1)(ColumnA_Row, 1), ""     '                                       If name not previously seen in this row then ...
'                                                                                                           '                                               Save the name to the dictionary row
                                        Next                                                                '                                   Exit 'Fake loop'
'
                                        If UBound(oSD.keys) + 1 = lLastColumn Then                          '                                   If no duplicates found in row then ...
' The current row has no duplicate names
'
' Point to the next blank row in the NoDupeRowArray
                                            lWriteRow = lWriteRow + 1                                               '                           Increment lWriteRow
'
                                            NoDupeRowArray(lWriteRow, 1) = WorksheetColumnArray(1)(ColumnA_Row, 1)  '                           Save name from column A to NoDupeRowArray
                                            NoDupeRowArray(lWriteRow, 2) = WorksheetColumnArray(2)(ColumnB_Row, 1)  '                           Save name from column B to NoDupeRowArray
                                            NoDupeRowArray(lWriteRow, 3) = WorksheetColumnArray(3)(ColumnC_Row, 1)  '                           Save name from column C to NoDupeRowArray
                                            NoDupeRowArray(lWriteRow, 4) = WorksheetColumnArray(4)(ColumnD_Row, 1)  '                           Save name from column D to NoDupeRowArray
                                            NoDupeRowArray(lWriteRow, 5) = WorksheetColumnArray(5)(ColumnE_Row, 1)  '                           Save name from column E to NoDupeRowArray
                                            NoDupeRowArray(lWriteRow, 6) = WorksheetColumnArray(6)(ColumnF_Row, 1)  '                           Save name from column F to NoDupeRowArray
                                            NoDupeRowArray(lWriteRow, 7) = WorksheetColumnArray(7)(ColumnG_Row, 1)  '                           Save name from column G to NoDupeRowArray
                                            NoDupeRowArray(lWriteRow, 8) = WorksheetColumnArray(8)(ColumnH_Row, 1)  '                           Save name from column H to NoDupeRowArray
                                            NoDupeRowArray(lWriteRow, 9) = WorksheetColumnArray(9)(ColumnI_Row, 1)  '                           Save name from column I to NoDupeRowArray
'
                                            NoDupeRowArray(lWriteRow, lLastColumn + 1) = lIterationCount    '                                   Save lIterationCount to NoDupeRowArray
                                        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
'
    NoDupeRowArray = ReDimPreserve(NoDupeRowArray, lWriteRow, lLastColumn + 1)                              ' Resize NoDupeRowArray to correct the actual rows used in the array
'
    Debug.Print "Create all combinations & remove rows with duplicate entries in the same row completed " & _
            "in " & Format(Now() - StartTime, "hh:mm:ss")                                                   '   Display elapsed time for this process to the 'Immediate' window (CTRL+G) in VBE
'
'-------------------------------------------------------------------------------------------------------------------------------
'
' 3) Create a 'jagged array', which is just an array of arrays, of the remaining combinations. This us what allows us to handle
'       larger amounts of combinations. Instead of trying to write them all to the sheet for sorting, we will use the jagged array
'       to write amounts of combinations to the sheet that doesn't exceed the maximum amount of rows that Excel allows. We then
'       sort those rows & save the result back to the jagged array, clear the sheet, write the next array to the sheet, sort the data,
'       save it back to the jagged array, etc. When we are done, we combine all of those arrays in the jagged array back into
'       NoDupeSortedRowsArray for further processing.
'
    StartTime = Now()
'
    Application.StatusBar = "Step 2 of 5 ... 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
'
    currow = 0                                                                                              ' Reset currow
'
' Create array(s) of combinations
    For SubArrayNumber = 1 To SubArrays                                                                     ' Loop through SubArrays
        ReDim arrOut(1 To MaxRowsPerSubArray, 1 To UBound(NoDupeRowArray, 2))                               '   Reset the arrOut
'
        For SubArrayRow = 1 To MaxRowsPerSubArray                                                           '   Loop through rows of arrOut
            currow = currow + 1                                                                             '       Increment currow, this is the row of the NoDupeRowArray
'
            If currow > UBound(NoDupeRowArray, 1) Then Exit For                                             '       If all of the rows have been processed then exit this For loop
'
            For ArrayColumn = 1 To UBound(NoDupeRowArray, 2)                                                '       Loop through columns of NoDupeRowArray
                arrOut(SubArrayRow, ArrayColumn) = NoDupeRowArray(currow, ArrayColumn)                      '           Save column value into arrOut
            Next                                                                                            '       Loop back
        Next                                                                                                '   Loop back
'
        JaggedArray(SubArrayNumber) = arrOut                                                                '   Save the arrOut to the JaggedArray
    Next                                                                                                    ' Loop back
'
' At this point, all of the MaxRowsPerSubArray row subArrays have been loaded into the JaggedArray
'
' Write each subArray to the sheet, sort each row & save results back into the subArray
    For SubArrayNumber = 1 To SubArrays                                                                     ' Loop through SubArrays
        ActiveSheet.Range("K2").Resize(UBound(JaggedArray(SubArrayNumber), 1), _
                UBound(JaggedArray(SubArrayNumber), 2)) = JaggedArray(SubArrayNumber)                       '   Write the subArray to the sheet for sorting
'
' Sort each row
        ActiveSheet.Sort.SortFields.Clear                                                                   '
'
        lLastRow = Cells(Rows.Count, lFirstWriteColumn).End(xlUp).Row                                       '   Get lLastRow
'
        Set rngSortRange = Range(Cells(2, lFirstWriteColumn), Cells(lLastRow, lLastWriteColumn + 1))        '   Set the Range to be sorted
'
        For Each SortRowRange In rngSortRange.Rows                                                          '   Loop through each row of the range to be sorted
            SortRowRange.Sort Key1:=SortRowRange.Cells(1, 1), Order1:=xlAscending, _
                    Header:=xlNo, Orientation:=xlSortRows                                                   '       Sort each row alphabetically
        Next                                                                                                '   Loop back
'
' Load the sorted data back into the subArray
        JaggedArray(SubArrayNumber) = ActiveSheet.Range("K2").Resize(UBound(JaggedArray(SubArrayNumber), 1), _
                UBound(JaggedArray(SubArrayNumber), 2))                                                     '
'
        ActiveSheet.Range("K2").Resize(UBound(JaggedArray(SubArrayNumber), 1), _
                UBound(JaggedArray(SubArrayNumber), 2)).ClearContents                                       '   Clear the sort range
    Next                                                                                                    ' Loop back
'
' Join all of the sorted subArrays back into 1 large array
    ReDim NoDupeSortedRowsArray(1 To UBound(NoDupeRowArray, 1), 1 To UBound(NoDupeRowArray, 2) - 1)         '
'
    currow = 0                                                                                              ' Reset currow
'
    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
            currow = currow + 1                                                                             '       Increment currow, this is the row of the NoDupeSortedRowsArray
'
            If currow > UBound(NoDupeSortedRowsArray, 1) Then Exit For                                      '       If all sorted rows have been written to NoDupeSortedRowsArray then exit this loop
'
            For ArrayColumn = 1 To UBound(NoDupeSortedRowsArray, 2)                                         '       Loop through columns of NoDupeSortedRowsArray
                NoDupeSortedRowsArray(currow, ArrayColumn) = _
                        JaggedArray(SubArrayNumber)(SubArrayRow, ArrayColumn)                               '           Save column value into NoDupeSortedRowsArray
            Next                                                                                            '       Loop back
        Next                                                                                                '   Loop back
    Next                                                                                                    ' Loop back
'
    Erase arrOut
    Erase JaggedArray
'
    Debug.Print "Sorting remaining combination rows alphabetically by row completed " & _
            "in " & Format(Now() - StartTime, "hh:mm:ss")                                                   '   Display elapsed time for this process to the 'Immediate' window (CTRL+G) in VBE
'
' At this point, all of the MaxRowsPerSubArray sorted row subArrays have been loaded into the
'       NoDupeSortedRowsArray, last column (ComboID) is now first column though due to the sorting ;)
'
'-------------------------------------------------------------------------------------------------------------------------------
'
' 4) Join names in each remaining combination row by adding a delimiter between each name and save those strings to keysArray
'
    StartTime = Now()
'
    Application.StatusBar = "Step 3 of 5 ... Removing duplicate sorted rows ..."
    DoEvents
'
' Time to eliminate the duplicate rows in NoDupeSortedRowsArray
'
    ReDim keysArray(1 To UBound(NoDupeSortedRowsArray, 1), 1 To 1)                                          ' Set # of rows/columns of keysArray
'
' Combine each name in each row, separated by a Delimiter, to oSD_KeyString
    For ArrayRow = LBound(NoDupeSortedRowsArray, 1) To UBound(NoDupeSortedRowsArray, 1)                     ' Loop through rows of NoDupeSortedRowsArray
        oSD_KeyString = ""                                                                                  '   Erase 'oSD_KeyString'
        Delimiter = ""                                                                                      '   Erase 'Delimiter' of NoDupeSortedRowsArray
'
        For ArrayColumn = LBound(NoDupeSortedRowsArray, 2) + 1 To UBound(NoDupeSortedRowsArray, 2)          '   Loop through name columns of NoDupeSortedRowsArray
            oSD_KeyString = oSD_KeyString & Delimiter & NoDupeSortedRowsArray(ArrayRow, ArrayColumn)    '       Save names from NoDupeSortedRowsArray row, separated by Delimiter, into oSD_KeyString
            Delimiter = Chr(2)
        Next                                                                                                '   Loop back
'
        keysArray(ArrayRow, 1) = " " & Delimiter & oSD_KeyString                                            '   Save oSD_KeyString to keysArray
        oSD(oSD_KeyString) = True
    Next                                                                                                    ' Loop back
'
'-------------------------------------------------------------------------------------------------------
'
' 5) Save unique strings of names in the keysArray to UniqueSortedRowsArray
'
    ReDim UniqueSortedRowsArray(LBound(NoDupeSortedRowsArray, 1) To oSD.Count + (LBound(NoDupeSortedRowsArray, 1) - 1), _
            LBound(NoDupeSortedRowsArray, 2) To UBound(NoDupeSortedRowsArray, 2) + 1)                       ' Set # of rows/columns of UniqueSortedRowsArray
'
    currow = LBound(NoDupeSortedRowsArray, 1) - 1                                                           ' Initialize currow
'
    For ArrayRow = LBound(NoDupeSortedRowsArray, 1) To UBound(NoDupeSortedRowsArray, 1)                     ' Loop through rows of NoDupeSortedRowsArray
        If Not oSD.Exists(keysArray(ArrayRow, 1)) Then                                                      '   If this is a unique sorted name row then ...
            oSD.Add keysArray(ArrayRow, 1), ""                                                              '       Add it to the dictionary
'
            currow = currow + 1                                                                             '       Increment currow
'
            UniqueSortedRowsArray(currow, UBound(UniqueSortedRowsArray, 2)) = _
                    NoDupeSortedRowsArray(ArrayRow, 1)                                                      '       Save the combination # to UniqueSortedRowsArray
'
            For ArrayColumn = LBound(NoDupeSortedRowsArray, 2) + 1 To UBound(NoDupeSortedRowsArray, 2)      '       Loop through columns of NoDupeSortedRowsArray
                UniqueSortedRowsArray(currow, ArrayColumn - 1) = _
                        NoDupeSortedRowsArray(ArrayRow, ArrayColumn)                                        '           Copy value to UniqueSortedRowsArray
            Next                                                                                            '       Loop back
'
            oSD(keysArray(ArrayRow, 1)) = False                                                             '       Flag this row as not unique      flag this key as copied
        End If
    Next                                                                                                    ' Loop back
'
    Set oSD = CreateObject("Scripting.Dictionary")                                                          ' Erase contents of dictionary
    Set oSD = Nothing                                                                                       ' Delete the dictionary
    Erase keysArray                                                                                         '
'
    UniqueSortedRowsArray = ReDimPreserve(UniqueSortedRowsArray, currow, UBound(UniqueSortedRowsArray, 2))  ' Correct the number of rows of UniqueSortedRowsArray
'
' At this point, UniqueSortedRowsArray has been created with sorted rows & with no duplicate rows & the ComboID has been added back
'
'-------------------------------------------------------------------------------------------------------
'
' 6) Now we need to match the ComboID in UniqueSortedRowsArray to the ComboID in NoDupeRowArray so we can
'       put the names for that row back to the original order & save to UniqueUnSortedRowsArray
'
    ReDim UniqueUnSortedRowsArray(1 To UBound(UniqueSortedRowsArray, 1), 1 To UBound(UniqueSortedRowsArray, 2)) ' Set the # of rows/columns for UniqueUnSortedRowsArray
    ReDim SalaryCalculationArray(1 To UBound(UniqueSortedRowsArray, 1), 1 To UBound(UniqueSortedRowsArray, 2))  ' Set the # of rows/columns for SalaryArray
'
    currow = 1                                                                                              ' Initialize currow
'
    For ArrayRow = LBound(NoDupeRowArray, 1) To UBound(NoDupeRowArray, 1)                                   ' Loop through rows of NoDupeRowArray
        If currow > UBound(UniqueUnSortedRowsArray, 1) Then Exit For                                        '   If we have processed all rows then exit this For loop
'
        If UniqueSortedRowsArray(currow, UBound(UniqueSortedRowsArray, 2)) = _
                NoDupeRowArray(ArrayRow, UBound(NoDupeRowArray, 2)) Then                                    '   If we found matching ComboID's then ...
'
            For ArrayColumn = LBound(NoDupeRowArray, 2) To UBound(NoDupeRowArray, 2) - 1                    '       Loop through the columns of NoDupeRowArray except for the last column
                UniqueUnSortedRowsArray(currow, ArrayColumn) = NoDupeRowArray(ArrayRow, ArrayColumn)        '           Save the name from the row/column to UniqueUnSortedRowsArray
            Next                                                                                            '       Loop back
'
            UniqueUnSortedRowsArray(currow, UBound(UniqueUnSortedRowsArray, 2)) = _
                    NoDupeRowArray(ArrayRow, UBound(NoDupeRowArray, 2))                                     '       Save the ComboID to UniqueUnSortedRowsArray
'
            currow = currow + 1                                                                             '       Increment currow
        End If
    Next                                                                                                    ' Loop back
'
    Erase NoDupeRowArray                                                                                    '
'
    wksData.Cells(2, lFirstWriteColumn).Resize(UBound(UniqueUnSortedRowsArray, 1), _
            UBound(UniqueUnSortedRowsArray, 2)) = UniqueUnSortedRowsArray                                   ' Display UniqueUnSortedRowsArray to 'Worksheet'
'
''    Debug.Print "Restoring order of the sorted names combinations completed in " & Format(Now() - StartTime, "hh:mm:ss")    ' Display elapsed time for this process to the 'Immediate' window (CTRL+G) in VBE
'
    Debug.Print "Removing duplicate sorted rows completed in " & Format(Now() - StartTime, "hh:mm:ss")      '   Display elapsed time for this process to the 'Immediate' window (CTRL+G) in VBE
'
'-------------------------------------------------------------------------------------------------------
'
' 7) Copy data on sheet to next set of columns. Insert a column for the salary total of each row. Save the unique
'       names from the 'Worksheet' into UniqueWorksheetNamesArray. Save respective data from 'Salary' sheet into
'       SalarySheetShortenedArray. Replace copied names in column U:AC with the players respective
'       salary data in SalarySheetShortenedArray. Sum the salaries from each of those rows & save results into
'       the added Salary column.
'
    StartTime = Now()
'
    Application.StatusBar = "Step 4 of 5 ... Removing all combination rows with salaries > " & MaxSalaryAllowed & " ..."    '
    DoEvents                                                                                                '
'
    lLastRow = Cells(Rows.Count, lFirstWriteColumn).End(xlUp).Row                                           '
'
    Range(Cells(1, lFirstWriteColumn), Cells(lLastRow, lLastWriteColumn + 1)).Copy _
            Destination:=Cells(1, lLastWriteColumn + 2)                                                     ' Rows for SALARY ... Copy K1:T & lLastRow to U1:AD & lLastRow
    lFirstHSortColumn = lLastWriteColumn + 2                                                                ' 21 ie. column U
    lLastHSortColumn = Cells(1, Columns.Count).End(xlToLeft).Column - 1                                     ' 29 ie. column AC
'
    Columns(lLastHSortColumn + 1).Insert                                                                    ' Insert a column for the 'Salary' for that row
'
    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
'
    SalarySheetFullArray = names.Range("A2:" & _
            Split(Cells(names.Cells.Find("*", , xlFormulas, , xlByColumns, xlPrevious).Column).Address, "$")(1) & lLastSalaryRow)   '   Save all of the data from the 'Salary' aheet into 2D 1 based SalarySheetFullArray
'
    ReDim SalarySheetShortenedArray(1 To UBound(SalarySheetFullArray, 1), 1 To UBound(SalarySheetFullArray, 2)) ' Set 2D 1 based SalarySheetShortenedArray to the same size as SalarySheetFullArray
'
    currow = 0                                                                                                      ' Initialize currow
'
    For UniqueArrayRow = 1 To UBound(UniqueWorksheetNamesArray, 1)                                                  ' Loop through the rows of UniqueWorksheetNamesArray
        For ArrayRow = 1 To UBound(SalarySheetFullArray, 1)                                                         '   Loop through the rows of SalarySheetFullArray
            If UniqueWorksheetNamesArray(UniqueArrayRow, 1) = SalarySheetFullArray(ArrayRow, 1) Then                '       If the name from UniqueWorksheetNamesArray is found in SalarySheetFullArray then ...
                currow = currow + 1                                                                                 '           Increment currow
'
                For lColumnIndex = 1 To UBound(SalarySheetFullArray, 2)                                             '           Loop through the columns of SalarySheetFullArray
                    SalarySheetShortenedArray(currow, lColumnIndex) = SalarySheetFullArray(ArrayRow, lColumnIndex)  '               Save the values to SalarySheetShortenedArray
                Next                                                                                                '           Loop back
            End If
        Next                                                                                                        '   Loop back
    Next                                                                                                            ' Loop back
'
    SalarySheetShortenedArray = Application.Transpose(SalarySheetShortenedArray)                                    ' Transpose SalarySheetShortenedArray so we can correct the size (row count)
'
    ReDim Preserve SalarySheetShortenedArray(1 To UBound(SalarySheetFullArray, 2), 1 To currow)                     ' Set the row count to actual used rows
'
    SalarySheetShortenedArray = Application.Transpose(SalarySheetShortenedArray)                                    ' Transpose back the SalarySheetShortenedArray
'
    lLastRow = Cells(Rows.Count, lFirstWriteColumn).End(xlUp).Row                                                   '
'
    Set rngReplace = Range(Cells(2, lFirstHSortColumn), Cells(lLastRow, lLastHSortColumn))                          '
'
    For lRowIndex = 1 To UBound(SalarySheetShortenedArray, 1)                                                       '
        rngReplace.Replace What:=SalarySheetShortenedArray(lRowIndex, 1), _
                Replacement:=SalarySheetShortenedArray(lRowIndex, 2), LookAt:=xlWhole, _
                SearchOrder:=xlByRows, MatchCase:=False, SearchFormat:=False, ReplaceFormat:=False                  '
    Next                                                                                                            '
'
    lLastRowDeDuped = Cells(Rows.Count, lFirstWriteColumn).End(xlUp).Row                                            '
'
    lLastHTeamCol = Cells(1, Columns.Count).End(xlToLeft).Column - 2                                                '
'
' 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
'
'-------------------------------------------------------------------------------------------------------------------------------
'
' 8) Save the 'Salary' range of data into SalaryCalculationArray. Save allowable salary rows into SalaryCalcShortenedArray.
'       Match the ComboIDs for each row saved to the ComboIDs in UniqueUnSortedRowsArray so we can replace the
'       respective names to the salaries.
'
    SalaryCalculationArray = Range(Cells(2, lLastWriteColumn + 2), Cells(lLastRowDeDuped, lLastHTeamCol + 2))       '
    ReDim SalaryCalcShortenedArray(1 To UBound(SalaryCalculationArray, 1), 1 To UBound(SalaryCalculationArray, 2))  ' Set the # of rows/columns for SalaryCalcShortenedArray
'
    currow = 0                                                                                                      ' Initialize currow
'
    For ArrayRow = LBound(SalaryCalculationArray, 1) To UBound(SalaryCalculationArray, 1)                           ' Loop through rows of SalaryCalculationArray
        If SalaryCalculationArray(ArrayRow, UBound(SalaryCalculationArray, 2) - 1) <= MaxSalaryAllowed Then         '   If we have an allowable salary then ...
            currow = currow + 1                                                                                     '       Increment currow
'
            For ArrayColumn = LBound(SalaryCalculationArray, 2) To UBound(SalaryCalculationArray, 2)                '       Loop through the columns of SalaryCalculationArray
                SalaryCalcShortenedArray(currow, ArrayColumn) = SalaryCalculationArray(ArrayRow, ArrayColumn)       '           Save the data from the row to SalaryCalcShortenedArray
            Next                                                                                                    '       Loop back
        End If
    Next                                                                                                            '
'
    currow = 1                                                                                                      ' Initialize currow
'
    For ArrayRow = LBound(UniqueUnSortedRowsArray, 1) To UBound(UniqueUnSortedRowsArray, 1)                         ' Loop through rows of UniqueUnSortedRowsArray
        If UniqueUnSortedRowsArray(ArrayRow, UBound(UniqueUnSortedRowsArray, 2)) = _
                SalaryCalcShortenedArray(currow, UBound(SalaryCalculationArray, 2)) Then                            '   If we found matching ComboID's then ...
            For ArrayColumn = LBound(UniqueUnSortedRowsArray, 2) To UBound(UniqueUnSortedRowsArray, 2) - 1          '       Loop through the columns of UniqueUnSortedRowsArray except for the last column
                SalaryCalcShortenedArray(currow, ArrayColumn) = UniqueUnSortedRowsArray(ArrayRow, ArrayColumn)      '           Save the name from the row/column to SalaryCalcShortenedArray
            Next                                                                                                    '       Loop back
'
            currow = currow + 1                                                                                     '       Increment currow
        End If
    Next                                                                                                            ' Loop back
'
    Erase SalarySheetFullArray                                                                                      '
    Erase SalaryCalculationArray                                                                                    '
'
    SalaryCalcShortenedArray = ReDimPreserve(SalaryCalcShortenedArray, currow - 1, UBound(SalaryCalcShortenedArray, 2)) '
'
    Range(Columns(lFirstHSortColumn - 1), Columns(lLastHTeamCol)).Delete                                            ' Delete columns T:AC ... 20 thru 29
'
' lFirstWriteColumn = 11 = K  ... lLastWriteColumn + 2 = 21 ... lFirstHSortColumn = 21 = U ... lLastHTeamCol = 29 = AC

    Range(Cells(2, lFirstWriteColumn), Cells(lLastRowDeDuped, lFirstHSortColumn)).ClearContents                     ' Erase rest of calculated data from the 'Worksheet'
'
' At this point, all criteria for deletion of combination rows have been completed
'
    Cells(2, lFirstWriteColumn).Resize(UBound(SalaryCalcShortenedArray, 1), _
            UBound(SalaryCalcShortenedArray, 2)) = SalaryCalcShortenedArray                                         ' Display SalaryCalcShortenedArray to 'Worksheet'
'
' We need to swap the last 2 columns
    Columns(lLastWriteColumn + 1).Insert                                                                            ' Insert a blank column
    Columns(lFirstHSortColumn + 1).Cut Cells(1, lLastWriteColumn + 1)                                               ' Cut/paste the last column into the inserted column
'
    Debug.Print "Remove all combinations with salaries > " & MaxSalaryAllowed & " completed " & _
        "in " & Format(Now() - StartTime, "hh:mm:ss")                                                               ' Display elapsed time for this process to the 'Immediate' window (CTRL+G) in VBE
'
'-------------------------------------------------------------------------------------------------------------------------------
'
' 9) 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 5 of 5 ...Wrapping up ..."                                                           '
    DoEvents                                                                                                        '
'
    lLastRow = Cells(Rows.Count, lFirstWriteColumn).End(xlUp).Row                                                   '
'
    If lLastRow > 1 Then                                                                                            '
        Range(Cells(1, lFirstWriteColumn), Cells(lLastRow, lLastWriteColumn)).Copy Destination:=Cells(1, lFirstHSortColumn + 1) ' Rows for PROJECTION
'
        lLastHSortColumn2 = Cells(1, Columns.Count).End(xlToLeft).Column                                            '
'
        Range(Cells(1, lFirstWriteColumn), Cells(lLastRow, lLastWriteColumn)).Copy Destination:=Cells(1, lLastHSortColumn2 + 1) ' Rows for TEAM
'
        lFirstHSortColumn2 = lLastHSortColumn + 2                                                                   ' 31 ... AE
        lFirstHTeamCol = lLastHSortColumn2 + 1                                                                      ' 31 ... AE
        lLastHTeamCol = Cells(1, Columns.Count).End(xlToLeft).Column                                                ' 39 ... AM
'
        Set rngReplace2 = Range(Cells(2, lFirstHSortColumn + 1), Cells(lLastRow, lLastHSortColumn2))                ' 22 ... V ... 30 ... AD
        Set rngReplace3 = Range(Cells(2, lFirstHTeamCol), Cells(lLastRow, lLastHTeamCol))                           ' 31 ... AE ... 39 ... AM
'
        For lRowIndex = 1 To UBound(SalarySheetShortenedArray, 1)                                                   ' 1 to 37
'
'''''''''''''''''''''''''''''''''''''PROJECTION
            rngReplace2.Replace What:=SalarySheetShortenedArray(lRowIndex, 1), _
                Replacement:=SalarySheetShortenedArray(lRowIndex, 3), LookAt:=xlWhole, _
                SearchOrder:=xlByRows, MatchCase:=False, SearchFormat:=False, ReplaceFormat:=False                  '
'
'
         '''''''''''''''''''''''''''''''''''''TEAM
            rngReplace3.Replace What:=SalarySheetShortenedArray(lRowIndex, 1), _
                Replacement:=SalarySheetShortenedArray(lRowIndex, 4), LookAt:=xlWhole, _
                SearchOrder:=xlByRows, MatchCase:=False, SearchFormat:=False, ReplaceFormat:=False                  '
        Next                                                                                                        '
'
' Add Projection Column
        Cells(1, lLastHTeamCol + 2).Value = ChrW(931) & " Projection"                                               '
' Add Team Stack Column
        Cells(1, lLastHTeamCol + 3).Value = ChrW(931) & " Stack"                                                    '
' Add Team Stack Pos
        Cells(1, lLastHTeamCol + 4).Value = ChrW(931) & " Stack POS"                                                '
' Add 2nd Team Stack Column
        Cells(1, lLastHTeamCol + 5).Value = ChrW(931) & " Stack2"                                                   '
' Add 2nd Team Stack Pos
        Cells(1, lLastHTeamCol + 6).Value = ChrW(931) & " Stack2 POS"                                               '
' Filter 0-1
        Cells(1, lLastHTeamCol + 7).Value = ChrW(931) & " Filter"                                                   '
' Player 1 Filter
        Cells(1, lLastHTeamCol + 8).Value = ChrW(931) & " Player1"                                                  '
' Player 2 Filter
        Cells(1, lLastHTeamCol + 9).Value = ChrW(931) & " Player2"                                                  '
'
        With Range(Cells(2, lLastHTeamCol + 2), Cells(lLastRow, lLastHTeamCol + 2))
            .FormulaR1C1 = "=SUM(RC" & lFirstHSortColumn2 & ":RC" & lLastHSortColumn2 & ")"                         '
            Application.Calculate                                                                                   '
            .Value = .Value                                                                                         '
        End With
'
        With Range(Cells(2, lLastHTeamCol + 3), Cells(lLastRow, 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
'
        With Range(Cells(2, lLastHTeamCol + 4), Cells(lLastRow, lLastHTeamCol + 4))
            .Formula2R1C1 = "=TEXTJOIN("","",1,IF(RC[-12]:RC[-4]=RC[-1],R1C[-12]:R1C[-4],""""))"                    '
            Application.Calculate                                                                                   '
            .Value = .Value                                                                                         '
        End With
'
        With Range(Cells(2, lLastHTeamCol + 5), Cells(lLastRow, 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
'
        With Range(Cells(2, lLastHTeamCol + 6), Cells(lLastRow, lLastHTeamCol + 6))
            .Formula2R1C1 = "=TEXTJOIN("","",1,IF(RC[-12]:RC[-4]=RC[-1],R1C[-12]:R1C[-4],""""))"                    '
            Application.Calculate                                                                                   '
            .Value = .Value                                                                                         '
        End With
'
'-------------------------------------------------------------------------------------------------------------------------------
'
' 10) "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 + 7), Cells(lLastRow, lLastHTeamCol + 7))                                 '
        End With
'
        With Range(Cells(2, lLastHTeamCol + 8), Cells(lLastRow, lLastHTeamCol + 8))                                 '
        End With
'
        With Range(Cells(2, lLastHTeamCol + 9), Cells(lLastRow, lLastHTeamCol + 9))                                 '
        End With
    Else                                                                                                            '
        MsgBox "No rows qualified for further testing."                                                             '
        lFirstHTeamCol = Cells(1, Columns.Count).End(xlToLeft).Column                                               '
    End If
'
'-------------------------------------------------------------------------------------------------------------------------------
'
' 11) 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
'
' lFirstWriteColumn = 11 = K  ... lLastWriteColumn + 2 = 21 ... lFirstHSortColumn = 21 = U ... lLastHTeamCol = 29 = AC
    Range(Columns(lFirstHSortColumn + 1), Columns(lLastHTeamCol + 1)).Delete                                        ' Delete columns V:AN ... 22 thru 40
'
    If ComboID_Display = False Then Columns(lLastWriteColumn + 1).Delete                                            ' Delete ComboID column if user chose not to see it
'
    ActiveSheet.UsedRange.Columns.AutoFit                                                                           '
'
    sOutput = lLastIteration & vbTab & " possible combinations" & vbLf & _
        lLastRow - 1 & vbTab & " unique name combinations" & vbLf & _
        IIf(lLastRow < lLastRow, lLastRow - lLastRow & vbTab & " duplicate rows removed." & vbLf, "") & _
        lLastRow - 1 & vbTab & " printed." & vbLf & vbLf & _
        Format(Now() - dteStart, "hh:mm:ss") & " to process."                                                       '
'
End_Sub:
    Call OptimizeCode_End
'
    Debug.Print "Wrapping up completed in " & Format(Now() - StartTime, "hh:mm:ss")                                 ' Display elapsed time for this process to the 'Immediate' window (CTRL+G) in VBE
'
    Debug.Print sOutput                                                                                             '
    MsgBox sOutput, , "Output Report"                                                                               '
End Sub



Public Function ReDimPreserve(ArrayNameToResize, NewRowUbound, NewColumnUbound)
'
' Code inspired by Control Freak
'
' Preserve & 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
'
        If IsArray(NewResizedArray) Then ReDimPreserve = NewResizedArray
    End If
End Function
```

There are a few settings towards the top of the script that you might want to pay special attention to ... the ones commented with '<---'

The code should also handle larger amounts of combinations as you requested in the original post here. Again, please read the comments to see how that was made possible. There is a spot further down the code where we may need to adapt previous ways to 'allow' even more combinations, but hopefully that won't be necessary.

Please let me know how it goes for you.


----------



## cspengel (Dec 11, 2022)

johnnyL said:


> Here are the results from the latest code I came up with:
> 
> 
> ```
> ...


Thanks JohnnyL! I'm going to look through the code more a bit later. Trying to get a few lineups into today's football contests 😅. I ran 2 tests(same data I used on the previous working code), but the projections did not add up correctly. Could be user error so I'm re-running another test. Another thing I encountered was after I click to run the macro and the diologue box pops up showing the amount of combinations and whether I want to continue. I hit cancel and it still ran the macro and then went to not responding mode so I couldn't back out try to end the macro via ctrl+break.. Had to just close it via task manager and redo as the data was lost. On the 2nd attempt I allowed it to try too many combinations just for the sake of it. (10million) and ran out of memory so it stopped lol. Appreciate your work, and will do more tests and take a better look at your code a bit later. Thanks again!


----------



## cspengel (Dec 11, 2022)

Projections added up correctly so disregard that part!


----------



## cspengel (Dec 11, 2022)

I tried running a test with 1.8 million combinations and I received a object defined error at this point. It does not occur if under the 1,024,000 though.


----------



## johnnyL (Dec 11, 2022)

I think you are running the wrong code. That code you just posted is not in my latest code.


----------



## cspengel (Dec 11, 2022)

Maybe after my memory error and it crashed I forgot to repaste the code again 😅. My bad ill test again in a bit. Sorry about that.


----------



## johnnyL (Dec 11, 2022)

Now we are getting somewhere.
Previous results from code posted in post # 83:

```
Create all combinations & remove rows with duplicate entries in the same row completed in 00:08:16
Sorting remaining combination rows alphabetically by row completed in 00:01:44
Removing duplicate sorted rows completed in 00:00:30
Remove all combinations with salaries > 60000 completed in 00:00:37
Wrapping up completed in 00:00:22
786240   possible combinations
60533    unique name combinations
60533    printed.

00:11:29 to process.
```

Result from current code I am working on:

```
Create all combinations & remove rows with duplicate entries in the same row completed in 00:00:22
Sorting remaining combination rows alphabetically by row completed in 00:01:55
Removing duplicate sorted rows completed in 00:00:31
Remove all combinations with salaries > 60000 completed in 00:00:37
Wrapping up completed in 00:00:26
786240   possible combinations
60533    unique name combinations
60533    printed.

00:03:51 to process.
```

Almost 4x faster. 

The first step which originally took over 15 minutes now runs in  just over 20 seconds. 👏


----------



## cspengel (Dec 12, 2022)

johnnyL said:


> Now we are getting somewhere.
> Previous results from code posted in post # 83:
> 
> ```
> ...


Awesome stuff JohnnyL! Your a genius! I 

Was able to do more tests on the last code posted. Was able to get a little over 1.6 million in 20 minutes, which is awesome to get passed that 1.2m mark. I look forward to testing out your new method! The projections were still not adding correctly so I was looking at how the helper columns were arranged. Because the projections and what not are calculated after previous columns are deleted, the following just needed to be changed 

This declaration needs to be changed: 

```
lFirstHSortColumn2 = lLastHSortColumn + 1
```

To this:

```
lFirstHSortColumn2 = lLastWriteColumn + 3
```


----------



## johnnyL (Dec 12, 2022)

Sorry for the delay, I had to correct a couple issues.

Here are the results from the latest code I came up with:

```
Create all combinations & remove rows with duplicate entries in the same row completed in 00:00:45
Sorting remaining combination rows alphabetically by row completed in 00:03:23
Removing duplicate sorted rows completed in 00:01:21
Remove all combinations with salaries > 60000 completed in 00:00:58
Wrapping up completed in 00:00:35
1572480  possible combinations
89839    unique name combinations
89839    printed.

00:07:02 to process.
```

The code is as follows:

```
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 NameCombosV15b()
    '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 ColumnNumber                    As Long
    Dim currow                          As Long
    Dim firstrow                        As Long, lLastRow                       As Long
    Dim lColumnIndex                    As Long
    Dim lFirstHSortColumn               As Long, lFirstHSortColumn2             As Long
    Dim lFirstHTeamCol                  As Long, lLastHTeamCol                  As Long
    Dim lFirstWriteColumn               As Long, lLastWriteColumn               As Long
    Dim lIndex                          As Long
    Dim lIterationCount                 As Long, lLastIteration                 As Long
    Dim lLastColumn                     As Long
    Dim lLastHSortColumn                As Long, lLastHSortColumn2              As Long
    Dim lLastRowDeDuped                 As Long
    Dim lLastSalaryRow                  As Long
    Dim lLastUsedColumn                 As Long
    Dim lRowIndex                       As Long
    Dim lWriteColumn                    As Long, lWriteRow                      As Long
    Dim MaxSalaryAllowed                As Long
    Dim SubArrayNumber                  As Long
    Dim SubArrayRow                     As Long
    Dim SubArrays                       As Long
    Dim UboundTempArray_1               As Long, UboundTempArray_2              As Long
    Dim UniqueArrayRow                  As Long
    Dim x                               As Long
    Dim oSD                             As Object
    Dim cel                             As Range
    Dim rngDataBlock                    As Range
    Dim rngFormulaRange                 As Range
    Dim rngReplace                      As Range, rngReplace2                   As Range, rngReplace3                   As Range
    Dim rngSortRange                    As Range
    Dim SortRowRange                    As Range
    Dim WorksheetNameRange              As Range
    Dim Delimiter                       As String
    Dim oSD_KeyString                   As String
    Dim sErrorMsg                       As String
    Dim sMissingSalary                  As String
    Dim sOutput                         As String
    Dim arrOut()                        As Variant
    Dim aryDeDupe                       As Variant
    Dim aryNames                        As Variant
    Dim JaggedArray()                   As Variant
    Dim keysArray                       As Variant
    Dim NoDupeRowArray()                As Variant, NoDupeRowShortenedArray()   As Variant
    Dim NoDupeSortedRowsArray()         As Variant
    Dim SalaryCalculationArray          As Variant, SalaryCalcShortenedArray()  As Variant
    Dim SalarySheetFullArray            As Variant, SalarySheetShortenedArray() As Variant
    Dim TempArray                       As Variant
    Dim UniqueSortedRowsArray           As Variant, UniqueUnSortedRowsArray()   As Variant
    Dim UniqueWorksheetNamesArray       As Variant
    Dim varK                            As Variant
    Dim WorksheetArray                  As Variant
    Dim WorksheetColumnArray()          As Variant
    Dim names                           As Worksheet
    Dim wks                             As Worksheet
    Dim wksData                         As Worksheet
'
    Const MaxRowsPerSubArray            As Long = 1000000                                                                        ' <--- Set the MaxRowsPerSubArray
    ComboID_Display = True                                                                                                      ' <--- Set this to True or False to see/not see the ComboID column
    MaxSalaryAllowed = 60000                                                                                                    ' <--- set this value to what you want
'
'-------------------------------------------------------------------------------------------------------------------------------
'
    Call OptimizeCode_Begin
'
    Set wksData = ThisWorkbook.Sheets("Worksheet")
    Set names = Sheets("Salary")
'
'-------------------------------------------------------------------------------------------------------------------------------
'
' 1) Take all the names entered on the "Worksheet" (A2:Ix) sheet and check to see if all of those names also have a salary listed on the "Salary" sheet.
'    If any of the names from "Worksheet" are not on the "Salary" sheet, it ends Sub. If all the names are on the salary sheet and there are corresponding
'    salaries for each of those names, a pop up box will appear letting you know how many combinations to expect.
'
    'Check for salary worksheet
    For Each wks In ThisWorkbook.Worksheets
        If wks.Name = "Salary" Then bFoundSalary = True
    Next
'
    If Not bFoundSalary Then
        MsgBox "The workbook must contain a worksheet named 'Salary' with data starting in row 2 " & _
            "that consists of column A containing each name in the name/column layout worksheet " & _
            "and column B containng their salary."
'
        GoTo End_Sub
    End If
'
    'Make sure each name has a corresponding salary entry
    'Initialize the scripting dictionary
    Set oSD = CreateObject("Scripting.Dictionary")
    oSD.CompareMode = vbTextCompare
'
    'Inventory names on the main worksheet
    For Each cel In ActiveSheet.Range("A1").CurrentRegion.Offset(1, 0)
        cel.Value = Trim(cel.Value)
'
        If cel.Value <> vbNullString Then
            oSD.Item(cel.Value) = oSD.Item(cel.Value) + 1
        End If
    Next
'
    'Remove names on the Salary worksheet
    With Worksheets("Salary")
        For Each cel In .Range("A2:A" & .Cells(Rows.Count, 1).End(xlUp).Row)
            cel.Value = Trim(cel.Value)
'
            If oSD.Exists(cel.Value) Then
                oSD.Remove cel.Value
            End If
        Next
    End With
'
    'Any names not accounted for?
    If oSD.Count <> 0 Then
        varK = oSD.keys
'
        For lIndex = LBound(varK) To UBound(varK)
            sMissingSalary = sMissingSalary & ", " & varK(lIndex)
        Next
'
        sMissingSalary = Mid(sMissingSalary, 3)
'
        sOutput = "The following names on the main worksheet do not have a corresponding entry on the 'Salary' worksheet." & vbLf & vbLf & sMissingSalary
'
        MsgBox sOutput
        Debug.Print sOutput
'
        GoTo End_Sub
    End If
'
    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
'
    lFirstWriteColumn = lLastColumn + 2
    lLastWriteColumn = (2 * lLastColumn) + 1
'
    Select Case MsgBox("Process a " & lLastColumn & " column table with " & _
        lLastIteration & " possible combinations?" & vbLf & vbLf & _
        "WARNING: Columns right of the input range will be erased before continuing.", vbOKCancel + vbExclamation + _
        vbDefaultButton2, "Process table?")
'
        Case vbCancel
            GoTo End_Sub
    End Select
'
'-------------------------------------------------------------------------------------------------------------------------------
'
' 2) Clear all columns to the right of Column I on the "Worksheet" sheet. Copy headers from A1:I1 on the "Worksheet" sheet to K1:S1 on the "Worksheet" sheet.
'    Add header "ComboID" to T1 on the "Worksheet" sheet. Create the combinations & if there are no duplicate names in the same combination row then write the
'    combination of names & lIterationCount to NoDupeRowArray.
'
    dteStart = Now()
    StartTime = Now()
'
    Application.StatusBar = "Step 1 of 5 ... Calculating name combinations & saving combinations with no duplicate names in same combination ..."
    DoEvents
'
    'Clear all columns right of input range
    If lLastUsedColumn > lLastColumn Then
        Range(Cells(1, lLastColumn + 1), Cells(1, lLastUsedColumn)).EntireColumn.ClearContents
    End If
'
' Save Worksheet data into 2D 1 based WorksheetArray
    Set WorksheetNameRange = wksData.Range("A2:" & Split(Cells(1, lLastColumn).Address, "$")(1) & _
            wksData.Range("A1").CurrentRegion.Find("*", , xlFormulas, , xlByRows, xlPrevious).Row)
    WorksheetArray = WorksheetNameRange
'
    ReDim NoDupeRowArray(1 To lLastIteration, 1 To lLastColumn + 1)                                         ' Set up NoDupeRowArray with rows = lLastIteration & columns 1 more than data range
'
    Cells(1, lLastWriteColumn + 1).Value = "ComboID"
'
    'Add Output Header
    Range(Cells(1, 1), Cells(1, lLastColumn)).Copy Destination:=Cells(1, lFirstWriteColumn)
'
' Load data from 'Worksheet', each column of data will be loaded into a separate array
    ReDim WorksheetColumnArray(1 To lLastColumn)                                                            ' Set the # of arrays in 'jagged' array WorksheetColumnArray
'
    For ColumnNumber = 1 To lLastColumn                                                                     ' Loop through the columns of 'Worksheet'
        lLastRow = Cells(Rows.Count, ColumnNumber).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(ColumnNumber) = 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(ColumnNumber)(ArrayRow, 1) = WorksheetArray(ArrayRow, ColumnNumber)        '       Save the data to WorksheetColumnArray()
        Next                                                                                                '   Loop back
    Next                                                                                                    ' Loop back
'
    'Start creating combinations
    lIterationCount = 0                                                                                     ' Reset lIterationCount
    lWriteRow = 0                                                                                           ' Reset lWriteRow
'
    ReDim TempArray(1 To lLastIteration, 1 To lLastColumn + 1)                                              ' Set up TempArray with rows = lLastIteration & columns 1 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
'
' 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
                                    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
'
    UboundTempArray_1 = UBound(TempArray, 1)                                                                '
    UboundTempArray_2 = UBound(TempArray, 2)                                                                '
'
    SubArrays = Int((UboundTempArray_1 - 1) / MaxRowsPerSubArray) + 1                                       ' Determine number of SubArrays needed
'
    ReDim JaggedArray(1 To SubArrays)                                                                       ' Set the # of SubArrays in JaggedArray
'
    currow = 0                                                                                              ' Reset currow
'
' Create array(s) of combinations
    For SubArrayNumber = 1 To SubArrays                                                                     ' Loop through SubArrays
        ReDim arrOut(1 To MaxRowsPerSubArray, 1 To UboundTempArray_2 + 1)                                   '   Reset the arrOut
'
        For SubArrayRow = 1 To MaxRowsPerSubArray                                                           '   Loop through rows of arrOut
            currow = currow + 1                                                                             '       Increment currow, this is the row of the TempArray
'
            If currow > UboundTempArray_1 Then Exit For                                                     '       If all of the rows have been processed then exit this For loop
'
            For ArrayColumn = 1 To UboundTempArray_2                                                        '       Loop through columns of TempArray
                arrOut(SubArrayRow, ArrayColumn) = TempArray(currow, ArrayColumn)                           '           Save column value into arrOut
            Next                                                                                            '       Loop back
        Next                                                                                                '   Loop back
'
        JaggedArray(SubArrayNumber) = arrOut                                                                '   Save the arrOut to the JaggedArray
'
        Erase arrOut                                                                                        '
    Next                                                                                                    ' Loop back
'
    Erase TempArray                                                                                         '
'
' At this point, all of the MaxRowsPerSubArray row subArrays have been loaded into the JaggedArray
'
    lLastUsedColumn = ActiveSheet.UsedRange.Columns.Count                                                   ' Get LastUsedColumn in the sheet

' Write each subArray to the sheet, add the formula to determine unique rows & save results back into the subArray
    For SubArrayNumber = 1 To SubArrays                                                                     ' Loop through SubArrays
        ActiveSheet.Range("K2").Resize(UBound(JaggedArray(SubArrayNumber), 1), _
                UBound(JaggedArray(SubArrayNumber), 2)) = JaggedArray(SubArrayNumber)                       '   Write the subArray to the sheet
'
' Add formula to each row
        lLastRow = Cells(Rows.Count, lFirstWriteColumn).End(xlUp).Row                                       '   Get lLastRow
'
        Set rngFormulaRange = Range(Cells(2, lLastUsedColumn + 1), Cells(lLastRow, lLastUsedColumn + 1))    '   Set the Range to place formulas
'
        With rngFormulaRange
            .Formula = "=MODE.MULT(MATCH($" & Split(Cells(1, lFirstWriteColumn).Address, "$")(1) & "2:$" & _
                    Split(Cells(1, lLastUsedColumn).Address, "$")(1) & "2,$" & _
                    Split(Cells(1, lFirstWriteColumn).Address, "$")(1) & "2:$" & _
                    Split(Cells(1, lLastUsedColumn).Address, "$")(1) & "2,0))"                              '
            Application.Calculate                                                                           '
            .Value = .Value                                                                                 '
        End With
'
' Load the data with formula results back into the subArray
        JaggedArray(SubArrayNumber) = ActiveSheet.Range("K2").Resize(UBound(JaggedArray(SubArrayNumber), 1), _
                UBound(JaggedArray(SubArrayNumber), 2))                                                     '
'
        ActiveSheet.Range("K2").Resize(UBound(JaggedArray(SubArrayNumber), 1), _
                UBound(JaggedArray(SubArrayNumber), 2)).ClearContents                                       '   Clear the data range
    Next                                                                                                    ' Loop back
'
' Join all of the subArrays back into 1 large array, only include the rows with no duplicate names in the row
    ReDim NoDupeRowArray(1 To UboundTempArray_1, 1 To UboundTempArray_2)                                    ' Set the # of rows/columns for NoDupeRowArray
'
    currow = 0                                                                                              ' Reset currow
'
    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
            If Application.WorksheetFunction.IsNA(JaggedArray(SubArrayNumber)(SubArrayRow, UBound(JaggedArray(SubArrayNumber), 2))) Then   '        If formula resulted in '#N/A' then ...
                currow = currow + 1                                                                         '           Increment currow, this is the row of the NoDupeRowArray
'
                For ArrayColumn = 1 To UBound(JaggedArray(SubArrayNumber), 2) - 1                           '           Loop through columns of JaggedArray(SubArrayNumber)
                    NoDupeRowArray(currow, 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                                                                                       '
'
    NoDupeRowArray = ReDimPreserve(NoDupeRowArray, currow, lLastColumn + 1)                                 ' Resize NoDupeRowArray to correct the actual rows used in the array
'
    Debug.Print "Create all combinations & remove rows with duplicate entries in the same row completed " & _
            "in " & Format(Now() - StartTime, "hh:mm:ss")                                                   ' Display elapsed time for this process to the 'Immediate' window (CTRL+G) in VBE
'
'-------------------------------------------------------------------------------------------------------------------------------
'
' 3) Create a 'jagged array', which is just an array of arrays, of the remaining combinations. This us what allows us to handle
'       larger amounts of combinations. Instead of trying to write them all to the sheet for sorting, we will use the jagged array
'       to write amounts of combinations to the sheet that doesn't exceed the maximum amount of rows that Excel allows. We then
'       sort those rows & save the result back to the jagged array, clear the sheet, write the next array to the sheet, sort the data,
'       save it back to the jagged array, etc. When we are done, we combine all of those arrays in the jagged array back into
'       NoDupeSortedRowsArray for further processing.
'
    StartTime = Now()
'
    Application.StatusBar = "Step 2 of 5 ... 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
'
    currow = 0                                                                                              ' Reset currow
'
' Create array(s) of combinations
    For SubArrayNumber = 1 To SubArrays                                                                     ' Loop through SubArrays
        ReDim arrOut(1 To MaxRowsPerSubArray, 1 To UBound(NoDupeRowArray, 2))                               '   Reset the arrOut
'
        For SubArrayRow = 1 To MaxRowsPerSubArray                                                           '   Loop through rows of arrOut
            currow = currow + 1                                                                             '       Increment currow, this is the row of the NoDupeRowArray
'
            If currow > UBound(NoDupeRowArray, 1) Then Exit For                                             '       If all of the rows have been processed then exit this For loop
'
            For ArrayColumn = 1 To UBound(NoDupeRowArray, 2)                                                '       Loop through columns of NoDupeRowArray
                arrOut(SubArrayRow, ArrayColumn) = NoDupeRowArray(currow, ArrayColumn)                      '           Save column value into arrOut
            Next                                                                                            '       Loop back
        Next                                                                                                '   Loop back
'
        JaggedArray(SubArrayNumber) = arrOut                                                                '   Save the arrOut to the JaggedArray
'
        Erase arrOut                                                                                        '
    Next                                                                                                    ' Loop back
'
' At this point, all of the MaxRowsPerSubArray row subArrays have been loaded into the JaggedArray
'
' Write each subArray to the sheet, sort each row & save results back into the subArray
    For SubArrayNumber = 1 To SubArrays                                                                     ' Loop through SubArrays
        ActiveSheet.Range("K2").Resize(UBound(JaggedArray(SubArrayNumber), 1), _
                UBound(JaggedArray(SubArrayNumber), 2)) = JaggedArray(SubArrayNumber)                       '   Write the subArray to the sheet for sorting
'
' Sort each row
        ActiveSheet.Sort.SortFields.Clear                                                                   '
'
        lLastRow = Cells(Rows.Count, lFirstWriteColumn).End(xlUp).Row                                       '   Get lLastRow
'
        Set rngSortRange = Range(Cells(2, lFirstWriteColumn), Cells(lLastRow, lLastWriteColumn + 1))        '   Set the Range to be sorted
'
        For Each SortRowRange In rngSortRange.Rows                                                          '   Loop through each row of the range to be sorted
            SortRowRange.Sort Key1:=SortRowRange.Cells(1, 1), Order1:=xlAscending, _
                    Header:=xlNo, Orientation:=xlSortRows                                                   '       Sort each row alphabetically
        Next                                                                                                '   Loop back
'
' Load the sorted data back into the subArray
        JaggedArray(SubArrayNumber) = ActiveSheet.Range("K2").Resize(UBound(JaggedArray(SubArrayNumber), 1), _
                UBound(JaggedArray(SubArrayNumber), 2))                                                     '
'
        ActiveSheet.Range("K2").Resize(UBound(JaggedArray(SubArrayNumber), 1), _
                UBound(JaggedArray(SubArrayNumber), 2)).ClearContents                                       '   Clear the sort range
    Next                                                                                                    ' Loop back
'
' Join all of the sorted subArrays back into 1 large array
    ReDim NoDupeSortedRowsArray(1 To UBound(NoDupeRowArray, 1), 1 To UBound(NoDupeRowArray, 2) - 1)         '
'
    currow = 0                                                                                              ' Reset currow
'
    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
            currow = currow + 1                                                                             '       Increment currow, this is the row of the NoDupeSortedRowsArray
'
            If currow > UBound(NoDupeSortedRowsArray, 1) Then Exit For                                      '       If all sorted rows have been written to NoDupeSortedRowsArray then exit this loop
'
            For ArrayColumn = 1 To UBound(NoDupeSortedRowsArray, 2)                                         '       Loop through columns of NoDupeSortedRowsArray
                NoDupeSortedRowsArray(currow, ArrayColumn) = _
                        JaggedArray(SubArrayNumber)(SubArrayRow, ArrayColumn)                               '           Save column value into NoDupeSortedRowsArray
            Next                                                                                            '       Loop back
        Next                                                                                                '   Loop back
'
        Erase JaggedArray(SubArrayNumber)                                                                   '
    Next                                                                                                    ' Loop back
'
    Erase JaggedArray
'
    Debug.Print "Sorting remaining combination rows alphabetically by row completed " & _
            "in " & Format(Now() - StartTime, "hh:mm:ss")                                                   '   Display elapsed time for this process to the 'Immediate' window (CTRL+G) in VBE
'
' At this point, all of the MaxRowsPerSubArray sorted row subArrays have been loaded into the
'       NoDupeSortedRowsArray, last column (ComboID) is now first column though due to the sorting ;)
'
'-------------------------------------------------------------------------------------------------------------------------------
'
' 4) Join names in each remaining combination row by adding a delimiter between each name and save those strings to keysArray
'
    StartTime = Now()
'
    Application.StatusBar = "Step 3 of 5 ... Removing duplicate sorted rows ..."
    DoEvents
'
' Time to eliminate the duplicate rows in NoDupeSortedRowsArray
'
    ReDim keysArray(1 To UBound(NoDupeSortedRowsArray, 1), 1 To 1)                                          ' Set # of rows/columns of keysArray
'
' Combine each name in each row, separated by a Delimiter, to oSD_KeyString
    For ArrayRow = LBound(NoDupeSortedRowsArray, 1) To UBound(NoDupeSortedRowsArray, 1)                     ' Loop through rows of NoDupeSortedRowsArray
        oSD_KeyString = ""                                                                                  '   Erase 'oSD_KeyString'
        Delimiter = ""                                                                                      '   Erase 'Delimiter' of NoDupeSortedRowsArray
'
        For ArrayColumn = LBound(NoDupeSortedRowsArray, 2) + 1 To UBound(NoDupeSortedRowsArray, 2)          '   Loop through name columns of NoDupeSortedRowsArray
            oSD_KeyString = oSD_KeyString & Delimiter & NoDupeSortedRowsArray(ArrayRow, ArrayColumn)    '       Save names from NoDupeSortedRowsArray row, separated by Delimiter, into oSD_KeyString
            Delimiter = Chr(2)
        Next                                                                                                '   Loop back
'
        keysArray(ArrayRow, 1) = " " & Delimiter & oSD_KeyString                                            '   Save oSD_KeyString to keysArray
        oSD(oSD_KeyString) = True
    Next                                                                                                    ' Loop back
'
'-------------------------------------------------------------------------------------------------------
'
' 5) Save unique strings of names in the keysArray to UniqueSortedRowsArray
'
    ReDim UniqueSortedRowsArray(LBound(NoDupeSortedRowsArray, 1) To oSD.Count + (LBound(NoDupeSortedRowsArray, 1) - 1), _
            LBound(NoDupeSortedRowsArray, 2) To UBound(NoDupeSortedRowsArray, 2) + 1)                       ' Set # of rows/columns of UniqueSortedRowsArray
'
    currow = LBound(NoDupeSortedRowsArray, 1) - 1                                                           ' Initialize currow
'
    For ArrayRow = LBound(NoDupeSortedRowsArray, 1) To UBound(NoDupeSortedRowsArray, 1)                     ' Loop through rows of NoDupeSortedRowsArray
        If Not oSD.Exists(keysArray(ArrayRow, 1)) Then                                                      '   If this is a unique sorted name row then ...
            oSD.Add keysArray(ArrayRow, 1), ""                                                              '       Add it to the dictionary
'
            currow = currow + 1                                                                             '       Increment currow
'
            UniqueSortedRowsArray(currow, UBound(UniqueSortedRowsArray, 2)) = _
                    NoDupeSortedRowsArray(ArrayRow, 1)                                                      '       Save the combination # to UniqueSortedRowsArray
'
            For ArrayColumn = LBound(NoDupeSortedRowsArray, 2) + 1 To UBound(NoDupeSortedRowsArray, 2)      '       Loop through columns of NoDupeSortedRowsArray
                UniqueSortedRowsArray(currow, ArrayColumn - 1) = _
                        NoDupeSortedRowsArray(ArrayRow, ArrayColumn)                                        '           Copy value to UniqueSortedRowsArray
            Next                                                                                            '       Loop back
'
            oSD(keysArray(ArrayRow, 1)) = False                                                             '       Flag this row as not unique      flag this key as copied
        End If
    Next                                                                                                    ' Loop back
'
    Set oSD = CreateObject("Scripting.Dictionary")                                                          ' Erase contents of dictionary
    Set oSD = Nothing                                                                                       ' Delete the dictionary
    Erase keysArray                                                                                         '
'
    UniqueSortedRowsArray = ReDimPreserve(UniqueSortedRowsArray, currow, UBound(UniqueSortedRowsArray, 2))  ' Correct the number of rows of UniqueSortedRowsArray
'
' At this point, UniqueSortedRowsArray has been created with sorted rows & with no duplicate rows & the ComboID has been added back
'
'-------------------------------------------------------------------------------------------------------
'
' 6) Now we need to match the ComboID in UniqueSortedRowsArray to the ComboID in NoDupeRowArray so we can
'       put the names for that row back to the original order & save to UniqueUnSortedRowsArray
'
    ReDim UniqueUnSortedRowsArray(1 To UBound(UniqueSortedRowsArray, 1), 1 To UBound(UniqueSortedRowsArray, 2)) ' Set the # of rows/columns for UniqueUnSortedRowsArray
    ReDim SalaryCalculationArray(1 To UBound(UniqueSortedRowsArray, 1), 1 To UBound(UniqueSortedRowsArray, 2))  ' Set the # of rows/columns for SalaryArray
'
    currow = 1                                                                                              ' Initialize currow
'
    For ArrayRow = LBound(NoDupeRowArray, 1) To UBound(NoDupeRowArray, 1)                                   ' Loop through rows of NoDupeRowArray
        If currow > UBound(UniqueUnSortedRowsArray, 1) Then Exit For                                        '   If we have processed all rows then exit this For loop
'
        If UniqueSortedRowsArray(currow, UBound(UniqueSortedRowsArray, 2)) = _
                NoDupeRowArray(ArrayRow, UBound(NoDupeRowArray, 2)) Then                                    '   If we found matching ComboID's then ...
'
            For ArrayColumn = LBound(NoDupeRowArray, 2) To UBound(NoDupeRowArray, 2) - 1                    '       Loop through the columns of NoDupeRowArray except for the last column
                UniqueUnSortedRowsArray(currow, ArrayColumn) = NoDupeRowArray(ArrayRow, ArrayColumn)        '           Save the name from the row/column to UniqueUnSortedRowsArray
            Next                                                                                            '       Loop back
'
            UniqueUnSortedRowsArray(currow, UBound(UniqueUnSortedRowsArray, 2)) = _
                    NoDupeRowArray(ArrayRow, UBound(NoDupeRowArray, 2))                                     '       Save the ComboID to UniqueUnSortedRowsArray
'
            currow = currow + 1                                                                             '       Increment currow
        End If
    Next                                                                                                    ' Loop back
'
    Erase NoDupeRowArray                                                                                    '
'
    wksData.Cells(2, lFirstWriteColumn).Resize(UBound(UniqueUnSortedRowsArray, 1), _
            UBound(UniqueUnSortedRowsArray, 2)) = UniqueUnSortedRowsArray                                   ' Display UniqueUnSortedRowsArray to 'Worksheet'
'
''    Debug.Print "Restoring order of the sorted names combinations completed in " & Format(Now() - StartTime, "hh:mm:ss")    ' Display elapsed time for this process to the 'Immediate' window (CTRL+G) in VBE
'
    Debug.Print "Removing duplicate sorted rows completed in " & Format(Now() - StartTime, "hh:mm:ss")      '   Display elapsed time for this process to the 'Immediate' window (CTRL+G) in VBE
'
'-------------------------------------------------------------------------------------------------------
'
' 7) Copy data on sheet to next set of columns. Insert a column for the salary total of each row. Save the unique
'       names from the 'Worksheet' into UniqueWorksheetNamesArray. Save respective data from 'Salary' sheet into
'       SalarySheetShortenedArray. Replace copied names in column U:AC with the players respective
'       salary data in SalarySheetShortenedArray. Sum the salaries from each of those rows & save results into
'       the added Salary column.
'
    StartTime = Now()
'
    Application.StatusBar = "Step 4 of 5 ... Removing all combination rows with salaries > " & MaxSalaryAllowed & " ..."    '
    DoEvents                                                                                                '
'
    lLastRow = Cells(Rows.Count, lFirstWriteColumn).End(xlUp).Row                                           '
'
    Range(Cells(1, lFirstWriteColumn), Cells(lLastRow, lLastWriteColumn + 1)).Copy _
            Destination:=Cells(1, lLastWriteColumn + 2)                                                     ' Rows for SALARY ... Copy K1:T & lLastRow to U1:AD & lLastRow
    lFirstHSortColumn = lLastWriteColumn + 2                                                                ' 21 ie. column U
    lLastHSortColumn = Cells(1, Columns.Count).End(xlToLeft).Column + 1                                     ' 31 ie. column AE
'
    Columns(lLastHSortColumn - 1).Insert                                                                    ' Insert column AD for the 'Salary'
'
    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
'
    SalarySheetFullArray = names.Range("A2:" & _
            Split(Cells(names.Cells.Find("*", , xlFormulas, , xlByColumns, xlPrevious).Column).Address, "$")(1) & lLastSalaryRow)   '   Save all of the data from the 'Salary' aheet into 2D 1 based SalarySheetFullArray
'
    ReDim SalarySheetShortenedArray(1 To UBound(SalarySheetFullArray, 1), 1 To UBound(SalarySheetFullArray, 2)) ' Set 2D 1 based SalarySheetShortenedArray to the same size as SalarySheetFullArray
'
    currow = 0                                                                                                      ' Initialize currow
'
    For UniqueArrayRow = 1 To UBound(UniqueWorksheetNamesArray, 1)                                                  ' Loop through the rows of UniqueWorksheetNamesArray
        For ArrayRow = 1 To UBound(SalarySheetFullArray, 1)                                                         '   Loop through the rows of SalarySheetFullArray
            If UniqueWorksheetNamesArray(UniqueArrayRow, 1) = SalarySheetFullArray(ArrayRow, 1) Then                '       If the name from UniqueWorksheetNamesArray is found in SalarySheetFullArray then ...
                currow = currow + 1                                                                                 '           Increment currow
'
                For lColumnIndex = 1 To UBound(SalarySheetFullArray, 2)                                             '           Loop through the columns of SalarySheetFullArray
                    SalarySheetShortenedArray(currow, lColumnIndex) = SalarySheetFullArray(ArrayRow, lColumnIndex)  '               Save the values to SalarySheetShortenedArray
                Next                                                                                                '           Loop back
            End If
        Next                                                                                                        '   Loop back
    Next                                                                                                            ' Loop back
'
    SalarySheetShortenedArray = Application.Transpose(SalarySheetShortenedArray)                                    ' Transpose SalarySheetShortenedArray so we can correct the size (row count)
'
    ReDim Preserve SalarySheetShortenedArray(1 To UBound(SalarySheetFullArray, 2), 1 To currow)                     ' Set the row count to actual used rows
'
    SalarySheetShortenedArray = Application.Transpose(SalarySheetShortenedArray)                                    ' Transpose back the SalarySheetShortenedArray
'
''    lLastRow = Cells(Rows.Count, lFirstWriteColumn).End(xlUp).Row                                                   '
'
    Set rngReplace = Range(Cells(2, lFirstHSortColumn), Cells(lLastRow, lLastHSortColumn - 2))                        '
'
    For lRowIndex = 1 To UBound(SalarySheetShortenedArray, 1)                                                       '
        rngReplace.Replace What:=SalarySheetShortenedArray(lRowIndex, 1), _
                Replacement:=SalarySheetShortenedArray(lRowIndex, 2), LookAt:=xlWhole, _
                SearchOrder:=xlByRows, MatchCase:=False, SearchFormat:=False, ReplaceFormat:=False                  '
    Next                                                                                                            '
'
    lLastRowDeDuped = Cells(Rows.Count, lFirstWriteColumn).End(xlUp).Row                                            '
'
''    lLastHTeamCol = lLastHSortColumn - 1                                             '
'
' Add Sum Column
    Cells(1, lLastHSortColumn - 1).Value = ChrW(931) & " Salary"                                                    ' 30 ... AD
'
    With Range(Cells(2, lLastHSortColumn - 1), Cells(lLastRowDeDuped, lLastHSortColumn - 1))
        .FormulaR1C1 = "=SUM(RC" & lFirstHSortColumn & ":RC" & lLastHSortColumn - 2 & ")"                             '
        Application.Calculate                                                                                       '
        .Value = .Value                                                                                             '
    End With
'
'-------------------------------------------------------------------------------------------------------------------------------
'
' 8) Save the 'Salary' range of data into SalaryCalculationArray. Save allowable salary rows into SalaryCalcShortenedArray.
'       Match the ComboIDs for each row saved to the ComboIDs in UniqueUnSortedRowsArray so we can replace the
'       respective names to the salaries.
'
    SalaryCalculationArray = Range(Cells(2, lFirstHSortColumn), Cells(lLastRowDeDuped, lLastHSortColumn))           '
    ReDim SalaryCalcShortenedArray(1 To UBound(SalaryCalculationArray, 1), 1 To UBound(SalaryCalculationArray, 2))  ' Set the # of rows/columns for SalaryCalcShortenedArray
'
    currow = 0                                                                                                      ' Initialize currow
'
    For ArrayRow = LBound(SalaryCalculationArray, 1) To UBound(SalaryCalculationArray, 1)                           ' Loop through rows of SalaryCalculationArray
        If SalaryCalculationArray(ArrayRow, UBound(SalaryCalculationArray, 2) - 1) <= MaxSalaryAllowed Then         '   If we have an allowable salary then ...
            currow = currow + 1                                                                                     '       Increment currow
'
            For ArrayColumn = LBound(SalaryCalculationArray, 2) To UBound(SalaryCalculationArray, 2)                '       Loop through the columns of SalaryCalculationArray
                SalaryCalcShortenedArray(currow, ArrayColumn) = SalaryCalculationArray(ArrayRow, ArrayColumn)       '           Save the data from the row to SalaryCalcShortenedArray
            Next                                                                                                    '       Loop back
        End If
    Next                                                                                                            '
'
' Replace the individual Salary amounts with the original individual names by matching up the ComboIDs
    currow = 1                                                                                                      ' Initialize currow
'
    For ArrayRow = LBound(UniqueUnSortedRowsArray, 1) To UBound(UniqueUnSortedRowsArray, 1)                         ' Loop through rows of UniqueUnSortedRowsArray
        If UniqueUnSortedRowsArray(ArrayRow, UBound(UniqueUnSortedRowsArray, 2)) = _
                SalaryCalcShortenedArray(currow, UBound(SalaryCalculationArray, 2)) Then                            '   If we found matching ComboID's then ...
            For ArrayColumn = LBound(UniqueUnSortedRowsArray, 2) To UBound(UniqueUnSortedRowsArray, 2) - 1          '       Loop through the columns of UniqueUnSortedRowsArray except for the last column
                SalaryCalcShortenedArray(currow, ArrayColumn) = UniqueUnSortedRowsArray(ArrayRow, ArrayColumn)      '           Save the name from the row/column to SalaryCalcShortenedArray
            Next                                                                                                    '       Loop back
'
            currow = currow + 1                                                                                     '       Increment currow
        End If
    Next                                                                                                            ' Loop back
'
    Erase UniqueUnSortedRowsArray
    Erase SalarySheetFullArray                                                                                      '
    Erase SalaryCalculationArray                                                                                    '
'
    SalaryCalcShortenedArray = ReDimPreserve(SalaryCalcShortenedArray, currow - 1, UBound(SalaryCalcShortenedArray, 2)) '
'
    Range(Columns(lFirstHSortColumn - 1), Columns(lLastHSortColumn - 2)).Delete                                     ' Delete columns T:AC ... 20 thru 29
    Range(Cells(2, lFirstWriteColumn), Cells(lLastRowDeDuped, lFirstHSortColumn)).ClearContents                     ' Erase rest of calculated data from the 'Worksheet'
'
' At this point, all criteria for deletion of combination rows have been completed
'
    Cells(2, lFirstWriteColumn).Resize(UBound(SalaryCalcShortenedArray, 1), _
            UBound(SalaryCalcShortenedArray, 2)) = SalaryCalcShortenedArray                                         ' Display SalaryCalcShortenedArray to 'Worksheet'
'
    Erase SalaryCalcShortenedArray                                                                                  '
'
' We need to swap the last 2 columns
    Columns(lLastWriteColumn + 1).Insert                                                                            ' Insert a blank column
    Columns(lFirstHSortColumn + 1).Cut Cells(1, lLastWriteColumn + 1)                                               ' Cut/paste the last column into the inserted column
'
    Debug.Print "Remove all combinations with salaries > " & MaxSalaryAllowed & " completed " & _
        "in " & Format(Now() - StartTime, "hh:mm:ss")                                                               ' Display elapsed time for this process to the 'Immediate' window (CTRL+G) in VBE
'
'-------------------------------------------------------------------------------------------------------------------------------
'
' 9) 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 5 of 5 ...Wrapping up ..."                                                           '
    DoEvents                                                                                                        '
'
    lLastRow = Cells(Rows.Count, lFirstWriteColumn).End(xlUp).Row                                                   '
'
    If lLastRow > 1 Then                                                                                            '
        Range(Cells(1, lFirstWriteColumn), Cells(lLastRow, lLastWriteColumn)).Copy Destination:=Cells(1, lFirstHSortColumn + 1) ' Rows for PROJECTION
'
        lLastHSortColumn2 = Cells(1, Columns.Count).End(xlToLeft).Column                                            ' 30 ... AD
'
        Range(Cells(1, lFirstWriteColumn), Cells(lLastRow, lLastWriteColumn)).Copy Destination:=Cells(1, lLastHSortColumn2 + 1) ' Rows for TEAM
'
        lFirstHSortColumn2 = lFirstHSortColumn + 1                                                                  ' 22 ... V
        lFirstHTeamCol = lLastHSortColumn2 + 1                                                                      ' 31 ... AE
        lLastHTeamCol = Cells(1, Columns.Count).End(xlToLeft).Column                                                ' 39 ... AM
'
        Set rngReplace2 = Range(Cells(2, lFirstHSortColumn2), Cells(lLastRow, lLastHSortColumn2))                   ' 22 ... V ... 30 ... AD
        Set rngReplace3 = Range(Cells(2, lFirstHTeamCol), Cells(lLastRow, lLastHTeamCol))                           ' 31 ... AE ... 39 ... AM
'
        For lRowIndex = 1 To UBound(SalarySheetShortenedArray, 1)                                                   ' 1 to 37
'
'''''''''''''''''''''''''''''''''''''PROJECTION
            rngReplace2.Replace What:=SalarySheetShortenedArray(lRowIndex, 1), _
                Replacement:=SalarySheetShortenedArray(lRowIndex, 3), LookAt:=xlWhole, _
                SearchOrder:=xlByRows, MatchCase:=False, SearchFormat:=False, ReplaceFormat:=False                  '
'
'
         '''''''''''''''''''''''''''''''''''''TEAM
            rngReplace3.Replace What:=SalarySheetShortenedArray(lRowIndex, 1), _
                Replacement:=SalarySheetShortenedArray(lRowIndex, 4), LookAt:=xlWhole, _
                SearchOrder:=xlByRows, MatchCase:=False, SearchFormat:=False, ReplaceFormat:=False                  '
        Next                                                                                                        '
'
' 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" & lFirstHSortColumn2 & ":RC" & lLastHSortColumn2 & ")"                         '       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
'
'-------------------------------------------------------------------------------------------------------------------------------
'
' 10) "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
'
'-------------------------------------------------------------------------------------------------------------------------------
'
' 11) 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 + 1), Columns(lLastHTeamCol)).Delete                                            ' Delete columns V:AM ... 22 thru 39
'
    If ComboID_Display = False Then Columns(lLastWriteColumn + 1).Delete                                            ' Delete ComboID column if user chose not to see it
'
    ActiveSheet.UsedRange.Columns.AutoFit                                                                           '
'
    sOutput = lLastIteration & vbTab & " possible combinations" & vbLf & _
        lLastRow - 1 & vbTab & " unique name combinations" & vbLf & _
        IIf(lLastRow < lLastRow, lLastRow - lLastRow & vbTab & " duplicate rows removed." & vbLf, "") & _
        lLastRow - 1 & vbTab & " printed." & vbLf & vbLf & _
        Format(Now() - dteStart, "hh:mm:ss") & " to process."                                                       '
'
End_Sub:
    Call OptimizeCode_End
'
    Debug.Print "Wrapping up completed in " & Format(Now() - StartTime, "hh:mm:ss")                                 ' Display elapsed time for this process to the 'Immediate' window (CTRL+G) in VBE
'
    Debug.Print sOutput                                                                                             '
    MsgBox sOutput, , "Output Report"                                                                               '
End Sub



Public Function ReDimPreserve(ArrayNameToResize, NewRowUbound, NewColumnUbound)
'
' Code inspired by Control Freak
'
' Preserve & 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
'
        If IsArray(NewResizedArray) Then ReDimPreserve = NewResizedArray
    End If
End Function
```

I tried to address a little bit of the error 7 memory issue  by deleting the arrays when finished with them. I think there is only so much excel can do. I mentioned previously that you are asking a lot from Excel. This is one of those points that I was eluding to.

Please try that code out & let me know your findings.


----------



## cspengel (Nov 25, 2022)

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



```
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
```


----------



## cspengel (Dec 13, 2022)

johnnyL said:


> Sorry for the delay, I had to correct a couple issues.
> 
> Here are the results from the latest code I came up with:
> 
> ...


Thanks Johnny, I will give it some tests tomorrow! Yeah, I figured it was reaching that point lol. I was looking it up and wasn't sure if adding more ram would help. It is the only part of my build that isn't that great. (16Gb). I was thinking what I could do is add a "filler" position in spots such as flex and defense. And instead of having a bunch of players listed to make combinations from will just be one name "filler" with a set salary and pt projection. Then once all the combos are generated I will manually change the best lines I choose to play with a few manually picked players. If I even do that with 3 positions, I could drastically reduce the amount of lineups generated while also including more players in other slots.


----------



## johnnyL (Dec 13, 2022)

I do have one more idea that we could try to allow more combinations, but I wanted your input on the current script before I tried to implement my last idea.


----------



## cspengel (Dec 13, 2022)

I.E


QBRBRB2WR1WR2WR3TEFLEXDSTJared GoffDerrick HenryDerrick HenryJustin JeffersonChristian KirkMarvin Jones Jr.FILL3FILL1FILL2Christian McCaffreyChristian McCaffreyAmon-Ra St. BrownDeebo SamuelJosh ReynoldsDalvin CookDalvin CookStefon DiggsAmari CooperLaviska Shenault Jr.Joe MixonJoe MixonCeeDee LambDeVonta SmithK.J. OsbornTony PollardTony PollardJa'Marr ChaseAdam ThielenRichie James Jr.Saquon BarkleySaquon BarkleyA.J. BrownDJ MooreIsaiah HodginsTravis Etienne Jr.Travis Etienne Jr.Tee HigginsGarrett WilsonDevin DuvernayNick ChubbNick ChubbDK MetcalfJerry JeudyTee HigginsEzekiel ElliottTyler LockettGabe DavisDK MetcalfD'Andre SwiftChris GodwinJuJu Smith-SchusterTyler LockettIsiah PachecoChris GodwinMiles SandersChristian KirkD'Onta ForemanDeebo SamuelDameon PierceAmari Cooper

Then on my salary sheet, I would designate those spots for an allocated salary such as


FILL17800​16​FILLFLEXFILL24800​7​FILLDFILL35900​8​FILLTE

This perhaps could reduce the amount of combos generated from over 900k to 180K or so. It would just be alittle time consuming to try and plug players in 150 or so chosen lineups. Perhaps I can ask another question on this forum at a later point to see if there is a way to randomly select players within the "Fill" spot and put them in my 150 chosen generated combos.


----------



## cspengel (Dec 13, 2022)

johnnyL said:


> I do have one more idea that we could try to allow more combinations, but I wanted your input on the current script before I tried to implement my last idea.


Okay cool, I'll get back to ya after a few tests. Thanks!


----------



## cspengel (Dec 13, 2022)

New code definitely runs quicker! Previous code took 20 minutes for 300k less combinations. I'd say a hell of an improvement! Pretty good amount of combinations ran too.






I tried it with 3,872,000 (I knew I was pushing it, but wanted to see if I would get memory error). Did not get memory error but received a random error code that did not point to any code, just stopped the macro.  Was in Step 3 of 5.




Awesome work though, as it runs so much quicker   How do you get that log info by the way?


----------



## johnnyL (Dec 13, 2022)

cspengel said:


> How do you get that log info by the way?



If you read through the code, as I asked you to previously, you would know that answer. a lot of the time I spend on code goes into commenting the code to make it easier for people that want to learn coding. The comments explain what is going on per line and per section.

In the window that shows the code (Alt+F11) ... ie. the VBE (Visual Basic Editor), if you press (CTRL+G), another window ('Immediate' window) should appear. That is the window where all of the 'Debug.Print' results are displayed. You should only have to press the CTRL+G once, save the workbook. From then on it should always display in the VBE.

As far as the memory error, like I said, I am still working on that issue.


----------



## johnnyL (Dec 13, 2022)

You can find one example of the commented code I just mentioned at the end of the main sub routine:

```
Debug.Print "Wrapping up completed in " & Format(Now() - StartTime, "hh:mm:ss")                                 ' Display elapsed time for this process to the 'Immediate' window (CTRL+G) in VBE
```

Does that sound familiar to my previous post where I said the answer is in the code?


----------



## johnnyL (Dec 13, 2022)

Debug.Print is basically an addition/alternative that you can use to a MsgBox display that is gone after the user responds to the MsgBox, the results in the 'Immediate' window will remain.


----------



## cspengel (Dec 13, 2022)

johnnyL said:


> You can find one example of the commented code I just mentioned at the end of the main sub routine:
> 
> ```
> Debug.Print "Wrapping up completed in " & Format(Now() - StartTime, "hh:mm:ss")                                 ' Display elapsed time for this process to the 'Immediate' window (CTRL+G) in VBE
> ...


I did read through the code and i will go back more and more to gain more knowledge, just not familiar with all of the options. When I first read that, I for some reason thought it was associated with the pop-up box at the end. Thanks for the information.  As for the memory, I know you are working on a solution, was just trying to show what I tried.


----------



## johnnyL (Dec 13, 2022)

Did you go to the VBE & Press CTRL+G? To see the 'log' as you referred to it?


----------



## cspengel (Nov 25, 2022)

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



```
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
```


----------



## johnnyL (Dec 13, 2022)

cspengel said:


> When I first read that, I for some reason thought it was associated with the pop-up box at the end. Thanks for the information.



Debug.Print is a totally different window. It is different than the pop up MsgBox. Two totally different animals.


----------



## cspengel (Dec 13, 2022)

johnnyL said:


> Debug.Print is a totally different window. It is different than the pop up MsgBox. Two totally different animals.



I realize that now, didn't know exactly what it was, my bad. I see the log now from the one I ran succesfully.


```
Create all combinations & remove rows with duplicate entries in the same row completed in 00:00:50
Sorting remaining combination rows alphabetically by row completed in 00:05:49
Removing duplicate sorted rows completed in 00:02:40
Remove all combinations with salaries > 60000 completed in 00:01:40
Wrapping up completed in 00:00:46
1936000  possible combinations
111413   unique name combinations
111413   printed.

00:11:45 to process.
Create all combinations & remove rows with duplicate entries in the same row completed in 00:01:45
Sorting remaining combination rows alphabetically by row completed in 00:19:06
Wrapping up completed in 00:38:01
```

The one that failed (over 3 million) was similar, just didn't get to the wrapping up phase I think.


```
Create all combinations & remove rows with duplicate entries in the same row completed in 00:01:59
Sorting remaining combination rows alphabetically by row completed in 00:20:14
```


----------



## johnnyL (Dec 13, 2022)

Nice!

I was just going to say the 'Create all combinations ...' is the first line
...
The last line, when completed successfully will be the:
'xx:xx:xx to process.'


----------



## johnnyL (Dec 13, 2022)

Still testing latest code that I came up with, but here are the results I received from the most recent test:


```
Create all combinations & remove rows with duplicate entries in the same row resulted in 1516320 rows completed in 00:00:55
Sorting remaining combination rows alphabetically by row completed in 00:04:48
Removing duplicate sorted rows completed in 00:02:35
Remove all combinations with salaries > 60000 completed in 00:01:26
Wrapping up completed in 00:01:00
2358720  possible combinations
126313   unique name combinations
126313   printed.

00:10:44 to process.
```

😛


----------



## cspengel (Dec 13, 2022)

johnnyL said:


> Still testing latest code that I came up with, but here are the results I received from the most recent test:
> 
> 
> ```
> ...



That is quick!  Nice work!
I removed some startup processes on my PC and ran another test.



```
Create all combinations & remove rows with duplicate entries in the same row completed in 00:01:38
Sorting remaining combination rows alphabetically by row completed in 00:10:26
Removing duplicate sorted rows completed in 00:08:27
Remove all combinations with salaries > 60000 completed in 00:03:03
Wrapping up completed in 00:01:41
3872000  possible combinations
241673   unique name combinations
241673   printed.

00:25:15 to process.
```

A memory error is not occurring during the macro  and had task manager up and the lowest it got was 5.5GB, but quickly went back up after the first couple minutes, so I don't think the Out Of Memory is a problem at the moment as I have not received that specific error again. Any more than the combinations there is on that test I get a "Error 400" which does not go to debugger. So I added a error handler.

I added a on error goto


```
On Error GoTo error_handler
```
 before this line of code


```
wksData.Cells(2, lFirstWriteColumn).Resize(UBound(UniqueUnSortedRowsArray, 1), _
            UBound(UniqueUnSortedRowsArray, 2)) = UniqueUnSortedRowsArray
```

this right before end sub
	
	
	
	
	
	



```
Exit Sub
error_handler:
    MsgBox Err.Description
```



That line of code is causing a application defined or object defined error per the popup box. I'm not sure why it only occurs with more combos


----------



## johnnyL (Dec 13, 2022)

Can you post the entire code?


----------



## cspengel (Dec 13, 2022)

```
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 = xlAutomatic
'
                      .ScreenUpdating = True
                           .StatusBar = False
    End With
End Sub


Sub NameCombosV15b()
    '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 ColumnNumber                    As Long
    Dim currow                          As Long
    Dim firstrow                        As Long, lLastRow                       As Long
    Dim lColumnIndex                    As Long
    Dim lFirstHSortColumn               As Long, lFirstHSortColumn2             As Long
    Dim lFirstHTeamCol                  As Long, lLastHTeamCol                  As Long
    Dim lFirstWriteColumn               As Long, lLastWriteColumn               As Long
    Dim lIndex                          As Long
    Dim lIterationCount                 As Long, lLastIteration                 As Long
    Dim lLastColumn                     As Long
    Dim lLastHSortColumn                As Long, lLastHSortColumn2              As Long
    Dim lLastRowDeDuped                 As Long
    Dim lLastSalaryRow                  As Long
    Dim lLastUsedColumn                 As Long
    Dim lRowIndex                       As Long
    Dim lWriteColumn                    As Long, lWriteRow                      As Long
    Dim MaxSalaryAllowed                As Long
    Dim SubArrayNumber                  As Long
    Dim SubArrayRow                     As Long
    Dim SubArrays                       As Long
    Dim UboundTempArray_1               As Long, UboundTempArray_2              As Long
    Dim UniqueArrayRow                  As Long
    Dim x                               As Long
    Dim oSD                             As Object
    Dim cel                             As Range
    Dim rngDataBlock                    As Range
    Dim rngFormulaRange                 As Range
    Dim rngReplace                      As Range, rngReplace2                   As Range, rngReplace3                   As Range
    Dim rngSortRange                    As Range
    Dim SortRowRange                    As Range
    Dim WorksheetNameRange              As Range
    Dim Delimiter                       As String
    Dim oSD_KeyString                   As Variant
    Dim sErrorMsg                       As String
    Dim sMissingSalary                  As String
    Dim sOutput                         As String
    Dim arrOut()                        As Variant
    Dim aryDeDupe                       As Variant
    Dim aryNames                        As Variant
    Dim JaggedArray()                   As Variant
    Dim keysArray                       As Variant
    Dim NoDupeRowArray()                As Variant, NoDupeRowShortenedArray()   As Variant
    Dim NoDupeSortedRowsArray()         As Variant
    Dim SalaryCalculationArray          As Variant, SalaryCalcShortenedArray()  As Variant
    Dim SalarySheetFullArray            As Variant, SalarySheetShortenedArray() As Variant
    Dim TempArray                       As Variant
    Dim UniqueSortedRowsArray           As Variant, UniqueUnSortedRowsArray()   As Variant
    Dim UniqueWorksheetNamesArray       As Variant
    Dim varK                            As Variant
    Dim WorksheetArray                  As Variant
    Dim WorksheetColumnArray()          As Variant
    Dim names                           As Worksheet
    Dim wks                             As Worksheet
    Dim wksData                         As Worksheet
'
    Const MaxRowsPerSubArray            As Long = 1000000                                                                    ' <--- Set the MaxRowsPerSubArray
    ComboID_Display = True                                                                                                      ' <--- Set this to True or False to see/not see the ComboID column
    MaxSalaryAllowed = 60000                                                                                                    ' <--- set this value to what you want
'
'-------------------------------------------------------------------------------------------------------------------------------
'
    Call OptimizeCode_Begin
'
    Set wksData = ThisWorkbook.Sheets("Worksheet")
    Set names = Sheets("Salary")
'
'-------------------------------------------------------------------------------------------------------------------------------
'
' 1) Take all the names entered on the "Worksheet" (A2:Ix) sheet and check to see if all of those names also have a salary listed on the "Salary" sheet.
'    If any of the names from "Worksheet" are not on the "Salary" sheet, it ends Sub. If all the names are on the salary sheet and there are corresponding
'    salaries for each of those names, a pop up box will appear letting you know how many combinations to expect.
'
    'Check for salary worksheet
    For Each wks In ThisWorkbook.Worksheets
        If wks.Name = "Salary" Then bFoundSalary = True
    Next
'
    If Not bFoundSalary Then
        MsgBox "The workbook must contain a worksheet named 'Salary' with data starting in row 2 " & _
            "that consists of column A containing each name in the name/column layout worksheet " & _
            "and column B containng their salary."
'
        GoTo End_Sub
    End If
'
    'Make sure each name has a corresponding salary entry
    'Initialize the scripting dictionary
    Set oSD = CreateObject("Scripting.Dictionary")
    oSD.CompareMode = vbTextCompare
'
    'Inventory names on the main worksheet
    For Each cel In ActiveSheet.Range("A1").CurrentRegion.Offset(1, 0)
        cel.Value = Trim(cel.Value)
'
        If cel.Value <> vbNullString Then
            oSD.Item(cel.Value) = oSD.Item(cel.Value) + 1
        End If
    Next
'
    'Remove names on the Salary worksheet
    With Worksheets("Salary")
        For Each cel In .Range("A2:A" & .Cells(Rows.Count, 1).End(xlUp).Row)
            cel.Value = Trim(cel.Value)
'
            If oSD.Exists(cel.Value) Then
                oSD.Remove cel.Value
            End If
        Next
    End With
'
    'Any names not accounted for?
    If oSD.Count <> 0 Then
        varK = oSD.keys
'
        For lIndex = LBound(varK) To UBound(varK)
            sMissingSalary = sMissingSalary & ", " & varK(lIndex)
        Next
'
        sMissingSalary = Mid(sMissingSalary, 3)
'
        sOutput = "The following names on the main worksheet do not have a corresponding entry on the 'Salary' worksheet." & vbLf & vbLf & sMissingSalary
'
        MsgBox sOutput
        Debug.Print sOutput
'
        GoTo End_Sub
    End If
'
    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
'
    lFirstWriteColumn = lLastColumn + 2
    lLastWriteColumn = (2 * lLastColumn) + 1
'
    Select Case MsgBox("Process a " & lLastColumn & " column table with " & _
        lLastIteration & " possible combinations?" & vbLf & vbLf & _
        "WARNING: Columns right of the input range will be erased before continuing.", vbOKCancel + vbExclamation + _
        vbDefaultButton2, "Process table?")
'
        Case vbCancel
            GoTo End_Sub
    End Select
'
'-------------------------------------------------------------------------------------------------------------------------------
'
' 2) Clear all columns to the right of Column I on the "Worksheet" sheet. Copy headers from A1:I1 on the "Worksheet" sheet to K1:S1 on the "Worksheet" sheet.
'    Add header "ComboID" to T1 on the "Worksheet" sheet. Create the combinations & if there are no duplicate names in the same combination row then write the
'    combination of names & lIterationCount to NoDupeRowArray.
'
    dteStart = Now()
    StartTime = Now()
'
    Application.StatusBar = "Step 1 of 5 ... Calculating name combinations & saving combinations with no duplicate names in same combination ..."
    DoEvents
'
    'Clear all columns right of input range
    If lLastUsedColumn > lLastColumn Then
        Range(Cells(1, lLastColumn + 1), Cells(1, lLastUsedColumn)).EntireColumn.ClearContents
    End If
'
' Save Worksheet data into 2D 1 based WorksheetArray
    Set WorksheetNameRange = wksData.Range("A2:" & Split(Cells(1, lLastColumn).Address, "$")(1) & _
            wksData.Range("A1").CurrentRegion.Find("*", , xlFormulas, , xlByRows, xlPrevious).Row)
    WorksheetArray = WorksheetNameRange
'
    ReDim NoDupeRowArray(1 To lLastIteration, 1 To lLastColumn + 1)                                         ' Set up NoDupeRowArray with rows = lLastIteration & columns 1 more than data range
'
    Cells(1, lLastWriteColumn + 1).Value = "ComboID"
'
    'Add Output Header
    Range(Cells(1, 1), Cells(1, lLastColumn)).Copy Destination:=Cells(1, lFirstWriteColumn)
'
' Load data from 'Worksheet', each column of data will be loaded into a separate array
    ReDim WorksheetColumnArray(1 To lLastColumn)                                                            ' Set the # of arrays in 'jagged' array WorksheetColumnArray
'
    For ColumnNumber = 1 To lLastColumn                                                                     ' Loop through the columns of 'Worksheet'
        lLastRow = Cells(Rows.Count, ColumnNumber).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(ColumnNumber) = 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(ColumnNumber)(ArrayRow, 1) = WorksheetArray(ArrayRow, ColumnNumber)        '       Save the data to WorksheetColumnArray()
        Next                                                                                                '   Loop back
    Next                                                                                                    ' Loop back
'
    'Start creating combinations
    lIterationCount = 0                                                                                     ' Reset lIterationCount
    lWriteRow = 0                                                                                           ' Reset lWriteRow
'
    ReDim TempArray(1 To lLastIteration, 1 To lLastColumn + 1)                                              ' Set up TempArray with rows = lLastIteration & columns 1 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
'
' 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
                                    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
'
    UboundTempArray_1 = UBound(TempArray, 1)                                                                '
    UboundTempArray_2 = UBound(TempArray, 2)                                                                '
'
    SubArrays = Int((UboundTempArray_1 - 1) / MaxRowsPerSubArray) + 1                                       ' Determine number of SubArrays needed
'
    ReDim JaggedArray(1 To SubArrays)                                                                       ' Set the # of SubArrays in JaggedArray
'
    currow = 0                                                                                              ' Reset currow
'
' Create array(s) of combinations
    For SubArrayNumber = 1 To SubArrays                                                                     ' Loop through SubArrays
        ReDim arrOut(1 To MaxRowsPerSubArray, 1 To UboundTempArray_2 + 1)                                   '   Reset the arrOut
'
        For SubArrayRow = 1 To MaxRowsPerSubArray                                                           '   Loop through rows of arrOut
            currow = currow + 1                                                                             '       Increment currow, this is the row of the TempArray
'
            If currow > UboundTempArray_1 Then Exit For                                                     '       If all of the rows have been processed then exit this For loop
'
            For ArrayColumn = 1 To UboundTempArray_2                                                        '       Loop through columns of TempArray
                arrOut(SubArrayRow, ArrayColumn) = TempArray(currow, ArrayColumn)                           '           Save column value into arrOut
            Next                                                                                            '       Loop back
        Next                                                                                                '   Loop back
'
        JaggedArray(SubArrayNumber) = arrOut                                                                '   Save the arrOut to the JaggedArray
'
        Erase arrOut                                                                                        '
    Next                                                                                                    ' Loop back
'
    Erase TempArray                                                                                         '
'
' At this point, all of the MaxRowsPerSubArray row subArrays have been loaded into the JaggedArray
'
    lLastUsedColumn = ActiveSheet.UsedRange.Columns.Count                                                   ' Get LastUsedColumn in the sheet

' Write each subArray to the sheet, add the formula to determine unique rows & save results back into the subArray
    For SubArrayNumber = 1 To SubArrays                                                                     ' Loop through SubArrays
        ActiveSheet.Range("K2").Resize(UBound(JaggedArray(SubArrayNumber), 1), _
                UBound(JaggedArray(SubArrayNumber), 2)) = JaggedArray(SubArrayNumber)                       '   Write the subArray to the sheet
'
' Add formula to each row
        lLastRow = Cells(Rows.Count, lFirstWriteColumn).End(xlUp).Row                                       '   Get lLastRow
'
        Set rngFormulaRange = Range(Cells(2, lLastUsedColumn + 1), Cells(lLastRow, lLastUsedColumn + 1))    '   Set the Range to place formulas
'
        With rngFormulaRange
            .Formula = "=MODE.MULT(MATCH($" & Split(Cells(1, lFirstWriteColumn).Address, "$")(1) & "2:$" & _
                    Split(Cells(1, lLastUsedColumn).Address, "$")(1) & "2,$" & _
                    Split(Cells(1, lFirstWriteColumn).Address, "$")(1) & "2:$" & _
                    Split(Cells(1, lLastUsedColumn).Address, "$")(1) & "2,0))"                              '
            Application.Calculate                                                                           '
            .Value = .Value                                                                                 '
        End With
'
' Load the data with formula results back into the subArray
        JaggedArray(SubArrayNumber) = ActiveSheet.Range("K2").Resize(UBound(JaggedArray(SubArrayNumber), 1), _
                UBound(JaggedArray(SubArrayNumber), 2))                                                     '
'
        ActiveSheet.Range("K2").Resize(UBound(JaggedArray(SubArrayNumber), 1), _
                UBound(JaggedArray(SubArrayNumber), 2)).ClearContents                                       '   Clear the data range
    Next                                                                                                    ' Loop back
'
' Join all of the subArrays back into 1 large array, only include the rows with no duplicate names in the row
    ReDim NoDupeRowArray(1 To UboundTempArray_1, 1 To UboundTempArray_2)                                    ' Set the # of rows/columns for NoDupeRowArray
'
    currow = 0                                                                                              ' Reset currow
'
    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
            If Application.WorksheetFunction.IsNA(JaggedArray(SubArrayNumber)(SubArrayRow, UBound(JaggedArray(SubArrayNumber), 2))) Then   '        If formula resulted in '#N/A' then ...
                currow = currow + 1                                                                         '           Increment currow, this is the row of the NoDupeRowArray
'
                For ArrayColumn = 1 To UBound(JaggedArray(SubArrayNumber), 2) - 1                           '           Loop through columns of JaggedArray(SubArrayNumber)
                    NoDupeRowArray(currow, 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                                                                                       '
'
    NoDupeRowArray = ReDimPreserve(NoDupeRowArray, currow, lLastColumn + 1)                                 ' Resize NoDupeRowArray to correct the actual rows used in the array
'
    Debug.Print "Create all combinations & remove rows with duplicate entries in the same row completed " & _
            "in " & Format(Now() - StartTime, "hh:mm:ss")                                                   ' Display elapsed time for this process to the 'Immediate' window (CTRL+G) in VBE
'
'-------------------------------------------------------------------------------------------------------------------------------
'
' 3) Create a 'jagged array', which is just an array of arrays, of the remaining combinations. This us what allows us to handle
'       larger amounts of combinations. Instead of trying to write them all to the sheet for sorting, we will use the jagged array
'       to write amounts of combinations to the sheet that doesn't exceed the maximum amount of rows that Excel allows. We then
'       sort those rows & save the result back to the jagged array, clear the sheet, write the next array to the sheet, sort the data,
'       save it back to the jagged array, etc. When we are done, we combine all of those arrays in the jagged array back into
'       NoDupeSortedRowsArray for further processing.
'
    StartTime = Now()
'
    Application.StatusBar = "Step 2 of 5 ... 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
'
    currow = 0                                                                                              ' Reset currow
'
' Create array(s) of combinations
    For SubArrayNumber = 1 To SubArrays                                                                     ' Loop through SubArrays
        ReDim arrOut(1 To MaxRowsPerSubArray, 1 To UBound(NoDupeRowArray, 2))                               '   Reset the arrOut
'
        For SubArrayRow = 1 To MaxRowsPerSubArray                                                           '   Loop through rows of arrOut
            currow = currow + 1                                                                             '       Increment currow, this is the row of the NoDupeRowArray
'
            If currow > UBound(NoDupeRowArray, 1) Then Exit For                                             '       If all of the rows have been processed then exit this For loop
'
            For ArrayColumn = 1 To UBound(NoDupeRowArray, 2)                                                '       Loop through columns of NoDupeRowArray
                arrOut(SubArrayRow, ArrayColumn) = NoDupeRowArray(currow, ArrayColumn)                      '           Save column value into arrOut
            Next                                                                                            '       Loop back
        Next                                                                                                '   Loop back
'
        JaggedArray(SubArrayNumber) = arrOut                                                                '   Save the arrOut to the JaggedArray
'
        Erase arrOut                                                                                        '
    Next                                                                                                    ' Loop back
'
' At this point, all of the MaxRowsPerSubArray row subArrays have been loaded into the JaggedArray
'
' Write each subArray to the sheet, sort each row & save results back into the subArray
    For SubArrayNumber = 1 To SubArrays                                                                     ' Loop through SubArrays
        ActiveSheet.Range("K2").Resize(UBound(JaggedArray(SubArrayNumber), 1), _
                UBound(JaggedArray(SubArrayNumber), 2)) = JaggedArray(SubArrayNumber)                       '   Write the subArray to the sheet for sorting
'
' Sort each row
        ActiveSheet.Sort.SortFields.Clear                                                                   '
'
        lLastRow = Cells(Rows.Count, lFirstWriteColumn).End(xlUp).Row                                       '   Get lLastRow
'
        Set rngSortRange = Range(Cells(2, lFirstWriteColumn), Cells(lLastRow, lLastWriteColumn + 1))        '   Set the Range to be sorted
'
        For Each SortRowRange In rngSortRange.Rows                                                          '   Loop through each row of the range to be sorted
            SortRowRange.Sort Key1:=SortRowRange.Cells(1, 1), Order1:=xlAscending, _
                    Header:=xlNo, Orientation:=xlSortRows                                                   '       Sort each row alphabetically
        Next                                                                                                '   Loop back
'
' Load the sorted data back into the subArray
        JaggedArray(SubArrayNumber) = ActiveSheet.Range("K2").Resize(UBound(JaggedArray(SubArrayNumber), 1), _
                UBound(JaggedArray(SubArrayNumber), 2))                                                     '
'
        ActiveSheet.Range("K2").Resize(UBound(JaggedArray(SubArrayNumber), 1), _
                UBound(JaggedArray(SubArrayNumber), 2)).ClearContents                                       '   Clear the sort range
    Next                                                                                                    ' Loop back
'
' Join all of the sorted subArrays back into 1 large array
    ReDim NoDupeSortedRowsArray(1 To UBound(NoDupeRowArray, 1), 1 To UBound(NoDupeRowArray, 2) - 1)         '
'
    currow = 0                                                                                              ' Reset currow
'
    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
            currow = currow + 1                                                                             '       Increment currow, this is the row of the NoDupeSortedRowsArray
'
            If currow > UBound(NoDupeSortedRowsArray, 1) Then Exit For                                      '       If all sorted rows have been written to NoDupeSortedRowsArray then exit this loop
'
            For ArrayColumn = 1 To UBound(NoDupeSortedRowsArray, 2)                                         '       Loop through columns of NoDupeSortedRowsArray
                NoDupeSortedRowsArray(currow, ArrayColumn) = _
                        JaggedArray(SubArrayNumber)(SubArrayRow, ArrayColumn)                               '           Save column value into NoDupeSortedRowsArray
            Next                                                                                            '       Loop back
        Next                                                                                                '   Loop back
'
        Erase JaggedArray(SubArrayNumber)                                                                   '
    Next                                                                                                    ' Loop back
'
    Erase JaggedArray
'
    Debug.Print "Sorting remaining combination rows alphabetically by row completed " & _
            "in " & Format(Now() - StartTime, "hh:mm:ss")                                                   '   Display elapsed time for this process to the 'Immediate' window (CTRL+G) in VBE
'
' At this point, all of the MaxRowsPerSubArray sorted row subArrays have been loaded into the
'       NoDupeSortedRowsArray, last column (ComboID) is now first column though due to the sorting ;)
'
'-------------------------------------------------------------------------------------------------------------------------------
'
' 4) Join names in each remaining combination row by adding a delimiter between each name and save those strings to keysArray
'
    StartTime = Now()
'
    Application.StatusBar = "Step 3 of 5 ... Removing duplicate sorted rows ..."
    DoEvents
'
' Time to eliminate the duplicate rows in NoDupeSortedRowsArray
'
    ReDim keysArray(1 To UBound(NoDupeSortedRowsArray, 1), 1 To 1)                                          ' Set # of rows/columns of keysArray
'
' Combine each name in each row, separated by a Delimiter, to oSD_KeyString
    For ArrayRow = LBound(NoDupeSortedRowsArray, 1) To UBound(NoDupeSortedRowsArray, 1)                     ' Loop through rows of NoDupeSortedRowsArray
        oSD_KeyString = ""                                                                                  '   Erase 'oSD_KeyString'
        Delimiter = ""                                                                                      '   Erase 'Delimiter' of NoDupeSortedRowsArray
     
       
     
        For ArrayColumn = LBound(NoDupeSortedRowsArray, 2) + 1 To UBound(NoDupeSortedRowsArray, 2)          '   Loop through name columns of NoDupeSortedRowsArray
            oSD_KeyString = oSD_KeyString & Delimiter & NoDupeSortedRowsArray(ArrayRow, ArrayColumn)    '       Save names from NoDupeSortedRowsArray row, separated by Delimiter, into oSD_KeyString
            Delimiter = Chr(2)
        Next                                                                                                '   Loop back
       
        keysArray(ArrayRow, 1) = " " & Delimiter & oSD_KeyString                                            '   Save oSD_KeyString to keysArray
        oSD(oSD_KeyString) = True
    Next ' Loop back
   
'
'-------------------------------------------------------------------------------------------------------
'
' 5) Save unique strings of names in the keysArray to UniqueSortedRowsArray
'
    ReDim UniqueSortedRowsArray(LBound(NoDupeSortedRowsArray, 1) To oSD.Count + (LBound(NoDupeSortedRowsArray, 1) - 1), _
            LBound(NoDupeSortedRowsArray, 2) To UBound(NoDupeSortedRowsArray, 2) + 1)                       ' Set # of rows/columns of UniqueSortedRowsArray
'
    currow = LBound(NoDupeSortedRowsArray, 1) - 1                                                           ' Initialize currow
'
    For ArrayRow = LBound(NoDupeSortedRowsArray, 1) To UBound(NoDupeSortedRowsArray, 1)                     ' Loop through rows of NoDupeSortedRowsArray
        If Not oSD.Exists(keysArray(ArrayRow, 1)) Then                                                      '   If this is a unique sorted name row then ...
            oSD.Add keysArray(ArrayRow, 1), ""                                                              '       Add it to the dictionary
'
            currow = currow + 1                                                                             '       Increment currow
           
            UniqueSortedRowsArray(currow, UBound(UniqueSortedRowsArray, 2)) = _
                    NoDupeSortedRowsArray(ArrayRow, 1)                                                      '       Save the combination # to UniqueSortedRowsArray
'
            For ArrayColumn = LBound(NoDupeSortedRowsArray, 2) + 1 To UBound(NoDupeSortedRowsArray, 2)      '       Loop through columns of NoDupeSortedRowsArray
                UniqueSortedRowsArray(currow, ArrayColumn - 1) = _
                        NoDupeSortedRowsArray(ArrayRow, ArrayColumn)                                        '           Copy value to UniqueSortedRowsArray
            Next                                                                                            '       Loop back
'
            oSD(keysArray(ArrayRow, 1)) = False                                                             '       Flag this row as not unique      flag this key as copied
        End If
    Next                                                                                                    ' Loop back
   
    Set oSD = CreateObject("Scripting.Dictionary")                                                          ' Erase contents of dictionary
    Set oSD = Nothing ' Delete the dictionary
   
    Erase keysArray                                                                                         '
'
    UniqueSortedRowsArray = ReDimPreserve(UniqueSortedRowsArray, currow, UBound(UniqueSortedRowsArray, 2))  ' Correct the number of rows of UniqueSortedRowsArray
'
' At this point, UniqueSortedRowsArray has been created with sorted rows & with no duplicate rows & the ComboID has been added back
'
'-------------------------------------------------------------------------------------------------------
'
' 6) Now we need to match the ComboID in UniqueSortedRowsArray to the ComboID in NoDupeRowArray so we can
'       put the names for that row back to the original order & save to UniqueUnSortedRowsArray
   
    ReDim UniqueUnSortedRowsArray(1 To UBound(UniqueSortedRowsArray, 1), 1 To UBound(UniqueSortedRowsArray, 2)) ' Set the # of rows/columns for UniqueUnSortedRowsArray
    ReDim SalaryCalculationArray(1 To UBound(UniqueSortedRowsArray, 1), 1 To UBound(UniqueSortedRowsArray, 2))  ' Set the # of rows/columns for SalaryArray
'
    currow = 1                                                                                              ' Initialize currow
'
    For ArrayRow = LBound(NoDupeRowArray, 1) To UBound(NoDupeRowArray, 1)                                   ' Loop through rows of NoDupeRowArray
        If currow > UBound(UniqueUnSortedRowsArray, 1) Then Exit For                                        '   If we have processed all rows then exit this For loop
      
        If UniqueSortedRowsArray(currow, UBound(UniqueSortedRowsArray, 2)) = _
                NoDupeRowArray(ArrayRow, UBound(NoDupeRowArray, 2)) Then                                    '   If we found matching ComboID's then ...
'
            For ArrayColumn = LBound(NoDupeRowArray, 2) To UBound(NoDupeRowArray, 2) - 1                    '       Loop through the columns of NoDupeRowArray except for the last column
                UniqueUnSortedRowsArray(currow, ArrayColumn) = NoDupeRowArray(ArrayRow, ArrayColumn) '           Save the name from the row/column to UniqueUnSortedRowsArray
            
            Next                                                                                            '       Loop back

            UniqueUnSortedRowsArray(currow, UBound(UniqueUnSortedRowsArray, 2)) = _
                    NoDupeRowArray(ArrayRow, UBound(NoDupeRowArray, 2))                                     '       Save the ComboID to UniqueUnSortedRowsArray
'
            currow = currow + 1                                                                             '       Increment currow
          
        End If
    Next ' Loop back
'
    Erase NoDupeRowArray
'
    Application.StatusBar = "c0de Fails here"
    On Error GoTo error_handler
'
   
    wksData.Cells(2, lFirstWriteColumn).Resize(UBound(UniqueUnSortedRowsArray, 1), _
            UBound(UniqueUnSortedRowsArray, 2)) = UniqueUnSortedRowsArray                                 ' Display UniqueUnSortedRowsArray to 'Worksheet'
'
    Debug.Print "Restoring order of the sorted names combinations completed in " & Format(Now() - StartTime, "hh:mm:ss")    ' Display elapsed time for this process to the 'Immediate' window (CTRL+G) in VBE
'
    Debug.Print "Removing duplicate sorted rows completed in " & Format(Now() - StartTime, "hh:mm:ss")      '   Display elapsed time for this process to the 'Immediate' window (CTRL+G) in VBE
'
'-------------------------------------------------------------------------------------------------------
'
' 7) Copy data on sheet to next set of columns. Insert a column for the salary total of each row. Save the unique
'       names from the 'Worksheet' into UniqueWorksheetNamesArray. Save respective data from 'Salary' sheet into
'       SalarySheetShortenedArray. Replace copied names in column U:AC with the players respective
'       salary data in SalarySheetShortenedArray. Sum the salaries from each of those rows & save results into
'       the added Salary column.
'
    StartTime = Now()
'
    Application.StatusBar = "Step 4 of 5 ... Removing all combination rows with salaries > " & MaxSalaryAllowed & " ..."    '
    DoEvents                                                                                                '
'
    lLastRow = Cells(Rows.Count, lFirstWriteColumn).End(xlUp).Row                                           '
'
    Range(Cells(1, lFirstWriteColumn), Cells(lLastRow, lLastWriteColumn + 1)).Copy _
            Destination:=Cells(1, lLastWriteColumn + 2)                                                     ' Rows for SALARY ... Copy K1:T & lLastRow to U1:AD & lLastRow
    lFirstHSortColumn = lLastWriteColumn + 2                                                                ' 21 ie. column U
    lLastHSortColumn = Cells(1, Columns.Count).End(xlToLeft).Column + 1                                     ' 31 ie. column AE
'
    Columns(lLastHSortColumn - 1).Insert                                                                    ' Insert column AD for the 'Salary'
'
    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
'
    SalarySheetFullArray = names.Range("A2:" & _
            Split(Cells(names.Cells.Find("*", , xlFormulas, , xlByColumns, xlPrevious).Column).Address, "$")(1) & lLastSalaryRow)   '   Save all of the data from the 'Salary' aheet into 2D 1 based SalarySheetFullArray
'
    ReDim SalarySheetShortenedArray(1 To UBound(SalarySheetFullArray, 1), 1 To UBound(SalarySheetFullArray, 2)) ' Set 2D 1 based SalarySheetShortenedArray to the same size as SalarySheetFullArray
'
    currow = 0                                                                                                      ' Initialize currow
'
    For UniqueArrayRow = 1 To UBound(UniqueWorksheetNamesArray, 1)                                                  ' Loop through the rows of UniqueWorksheetNamesArray
        For ArrayRow = 1 To UBound(SalarySheetFullArray, 1)                                                         '   Loop through the rows of SalarySheetFullArray
            If UniqueWorksheetNamesArray(UniqueArrayRow, 1) = SalarySheetFullArray(ArrayRow, 1) Then                '       If the name from UniqueWorksheetNamesArray is found in SalarySheetFullArray then ...
                currow = currow + 1                                                                                 '           Increment currow
'
                For lColumnIndex = 1 To UBound(SalarySheetFullArray, 2)                                             '           Loop through the columns of SalarySheetFullArray
                    SalarySheetShortenedArray(currow, lColumnIndex) = SalarySheetFullArray(ArrayRow, lColumnIndex)  '               Save the values to SalarySheetShortenedArray
                Next                                                                                                '           Loop back
            End If
        Next                                                                                                        '   Loop back
    Next                                                                                                            ' Loop back
'
    SalarySheetShortenedArray = Application.Transpose(SalarySheetShortenedArray)                                    ' Transpose SalarySheetShortenedArray so we can correct the size (row count)
'
    ReDim Preserve SalarySheetShortenedArray(1 To UBound(SalarySheetFullArray, 2), 1 To currow)                     ' Set the row count to actual used rows
'
    SalarySheetShortenedArray = Application.Transpose(SalarySheetShortenedArray)                                    ' Transpose back the SalarySheetShortenedArray
'
''    lLastRow = Cells(Rows.Count, lFirstWriteColumn).End(xlUp).Row                                                   '
'
    Set rngReplace = Range(Cells(2, lFirstHSortColumn), Cells(lLastRow, lLastHSortColumn - 2))                        '
'
    For lRowIndex = 1 To UBound(SalarySheetShortenedArray, 1)                                                       '
        rngReplace.Replace What:=SalarySheetShortenedArray(lRowIndex, 1), _
                Replacement:=SalarySheetShortenedArray(lRowIndex, 2), LookAt:=xlWhole, _
                SearchOrder:=xlByRows, MatchCase:=False, SearchFormat:=False, ReplaceFormat:=False                  '
    Next                                                                                                            '
'
    lLastRowDeDuped = Cells(Rows.Count, lFirstWriteColumn).End(xlUp).Row                                            '
'
''    lLastHTeamCol = lLastHSortColumn - 1                                             '
'
' Add Sum Column
    Cells(1, lLastHSortColumn - 1).Value = ChrW(931) & " Salary"                                                    ' 30 ... AD
'
    With Range(Cells(2, lLastHSortColumn - 1), Cells(lLastRowDeDuped, lLastHSortColumn - 1))
        .FormulaR1C1 = "=SUM(RC" & lFirstHSortColumn & ":RC" & lLastHSortColumn - 2 & ")"                             '
        Application.Calculate                                                                                       '
        .Value = .Value                                                                                             '
    End With
'
'-------------------------------------------------------------------------------------------------------------------------------
'
' 8) Save the 'Salary' range of data into SalaryCalculationArray. Save allowable salary rows into SalaryCalcShortenedArray.
'       Match the ComboIDs for each row saved to the ComboIDs in UniqueUnSortedRowsArray so we can replace the
'       respective names to the salaries.
'
    SalaryCalculationArray = Range(Cells(2, lFirstHSortColumn), Cells(lLastRowDeDuped, lLastHSortColumn))           '
    ReDim SalaryCalcShortenedArray(1 To UBound(SalaryCalculationArray, 1), 1 To UBound(SalaryCalculationArray, 2))  ' Set the # of rows/columns for SalaryCalcShortenedArray
'
    currow = 0                                                                                                      ' Initialize currow
'
    For ArrayRow = LBound(SalaryCalculationArray, 1) To UBound(SalaryCalculationArray, 1)                           ' Loop through rows of SalaryCalculationArray
        If SalaryCalculationArray(ArrayRow, UBound(SalaryCalculationArray, 2) - 1) <= MaxSalaryAllowed Then         '   If we have an allowable salary then ...
            currow = currow + 1                                                                                     '       Increment currow
'
            For ArrayColumn = LBound(SalaryCalculationArray, 2) To UBound(SalaryCalculationArray, 2)                '       Loop through the columns of SalaryCalculationArray
                SalaryCalcShortenedArray(currow, ArrayColumn) = SalaryCalculationArray(ArrayRow, ArrayColumn)       '           Save the data from the row to SalaryCalcShortenedArray
            Next                                                                                                    '       Loop back
        End If
    Next                                                                                                            '
'
' Replace the individual Salary amounts with the original individual names by matching up the ComboIDs
    currow = 1                                                                                                      ' Initialize currow
'
    For ArrayRow = LBound(UniqueUnSortedRowsArray, 1) To UBound(UniqueUnSortedRowsArray, 1)                         ' Loop through rows of UniqueUnSortedRowsArray
        If UniqueUnSortedRowsArray(ArrayRow, UBound(UniqueUnSortedRowsArray, 2)) = _
                SalaryCalcShortenedArray(currow, UBound(SalaryCalculationArray, 2)) Then                            '   If we found matching ComboID's then ...
            For ArrayColumn = LBound(UniqueUnSortedRowsArray, 2) To UBound(UniqueUnSortedRowsArray, 2) - 1          '       Loop through the columns of UniqueUnSortedRowsArray except for the last column
                SalaryCalcShortenedArray(currow, ArrayColumn) = UniqueUnSortedRowsArray(ArrayRow, ArrayColumn)      '           Save the name from the row/column to SalaryCalcShortenedArray
            Next                                                                                                    '       Loop back
'
            currow = currow + 1                                                                                     '       Increment currow
        End If
    Next                                                                                                            ' Loop back
'
    Erase UniqueUnSortedRowsArray
    Erase SalarySheetFullArray                                                                                      '
    Erase SalaryCalculationArray                                                                                    '
'
    SalaryCalcShortenedArray = ReDimPreserve(SalaryCalcShortenedArray, currow - 1, UBound(SalaryCalcShortenedArray, 2)) '
'
    Range(Columns(lFirstHSortColumn - 1), Columns(lLastHSortColumn - 2)).Delete                                     ' Delete columns T:AC ... 20 thru 29
    Range(Cells(2, lFirstWriteColumn), Cells(lLastRowDeDuped, lFirstHSortColumn)).ClearContents                     ' Erase rest of calculated data from the 'Worksheet'
'
' At this point, all criteria for deletion of combination rows have been completed
'
    Cells(2, lFirstWriteColumn).Resize(UBound(SalaryCalcShortenedArray, 1), _
            UBound(SalaryCalcShortenedArray, 2)) = SalaryCalcShortenedArray                                         ' Display SalaryCalcShortenedArray to 'Worksheet'
'
    Erase SalaryCalcShortenedArray                                                                                  '
'
' We need to swap the last 2 columns
    Columns(lLastWriteColumn + 1).Insert                                                                            ' Insert a blank column
    Columns(lFirstHSortColumn + 1).Cut Cells(1, lLastWriteColumn + 1)                                               ' Cut/paste the last column into the inserted column
'
    Debug.Print "Remove all combinations with salaries > " & MaxSalaryAllowed & " completed " & _
        "in " & Format(Now() - StartTime, "hh:mm:ss")                                                               ' Display elapsed time for this process to the 'Immediate' window (CTRL+G) in VBE
'
'-------------------------------------------------------------------------------------------------------------------------------
'
' 9) 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 5 of 5 ...Wrapping up ..."                                                           '
    DoEvents                                                                                                        '
'
    lLastRow = Cells(Rows.Count, lFirstWriteColumn).End(xlUp).Row                                                   '
'
    If lLastRow > 1 Then                                                                                            '
        Range(Cells(1, lFirstWriteColumn), Cells(lLastRow, lLastWriteColumn)).Copy Destination:=Cells(1, lFirstHSortColumn + 1) ' Rows for PROJECTION
'
        lLastHSortColumn2 = Cells(1, Columns.Count).End(xlToLeft).Column                                            ' 30 ... AD
'
        Range(Cells(1, lFirstWriteColumn), Cells(lLastRow, lLastWriteColumn)).Copy Destination:=Cells(1, lLastHSortColumn2 + 1) ' Rows for TEAM
'
        lFirstHSortColumn2 = lFirstHSortColumn + 1                                                                  ' 22 ... V
        lFirstHTeamCol = lLastHSortColumn2 + 1                                                                      ' 31 ... AE
        lLastHTeamCol = Cells(1, Columns.Count).End(xlToLeft).Column                                                ' 39 ... AM
'
        Set rngReplace2 = Range(Cells(2, lFirstHSortColumn2), Cells(lLastRow, lLastHSortColumn2))                   ' 22 ... V ... 30 ... AD
        Set rngReplace3 = Range(Cells(2, lFirstHTeamCol), Cells(lLastRow, lLastHTeamCol))                           ' 31 ... AE ... 39 ... AM
'
        For lRowIndex = 1 To UBound(SalarySheetShortenedArray, 1)                                                   ' 1 to 37
'
'''''''''''''''''''''''''''''''''''''PROJECTION
            rngReplace2.Replace What:=SalarySheetShortenedArray(lRowIndex, 1), _
                Replacement:=SalarySheetShortenedArray(lRowIndex, 3), LookAt:=xlWhole, _
                SearchOrder:=xlByRows, MatchCase:=False, SearchFormat:=False, ReplaceFormat:=False                  '
'
'
         '''''''''''''''''''''''''''''''''''''TEAM
            rngReplace3.Replace What:=SalarySheetShortenedArray(lRowIndex, 1), _
                Replacement:=SalarySheetShortenedArray(lRowIndex, 4), LookAt:=xlWhole, _
                SearchOrder:=xlByRows, MatchCase:=False, SearchFormat:=False, ReplaceFormat:=False                  '
        Next                                                                                                        '
'
' 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" & lFirstHSortColumn2 & ":RC" & lLastHSortColumn2 & ")"                         '       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
'
'-------------------------------------------------------------------------------------------------------------------------------
'
' 10) "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
'
'-------------------------------------------------------------------------------------------------------------------------------
'
' 11) 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 + 1), Columns(lLastHTeamCol)).Delete                                            ' Delete columns V:AM ... 22 thru 39
'
    If ComboID_Display = False Then Columns(lLastWriteColumn + 1).Delete                                            ' Delete ComboID column if user chose not to see it
'
    ActiveSheet.UsedRange.Columns.AutoFit                                                                           '
'
    sOutput = lLastIteration & vbTab & " possible combinations" & vbLf & _
        lLastRow - 1 & vbTab & " unique name combinations" & vbLf & _
        IIf(lLastRow < lLastRow, lLastRow - lLastRow & vbTab & " duplicate rows removed." & vbLf, "") & _
        lLastRow - 1 & vbTab & " printed." & vbLf & vbLf & _
        Format(Now() - dteStart, "hh:mm:ss") & " to process."                                                       '
'
End_Sub:
   
'
    Debug.Print "Wrapping up completed in " & Format(Now() - StartTime, "hh:mm:ss")                                 ' Display elapsed time for this process to the 'Immediate' window (CTRL+G) in VBE
'
    Debug.Print sOutput                                                                                             '
    MsgBox sOutput, , "Output Report" '
    Call OptimizeCode_End
    Exit Sub
error_handler:
    MsgBox Err.Description
End Sub



Public Function ReDimPreserve(ArrayNameToResize, NewRowUbound, NewColumnUbound)
'
' Code inspired by Control Freak
'
' Preserve & 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
'
        If IsArray(NewResizedArray) Then ReDimPreserve = NewResizedArray
    End If
End Function
```


----------



## johnnyL (Dec 14, 2022)

I quickly get error of runtime 7 with that code.


----------



## cspengel (Dec 14, 2022)

johnnyL said:


> I quickly get error of runtime 7 with that code.


Well what the heck 😑


----------



## johnnyL (Dec 14, 2022)

I will have to take a closer look at the code I have come up with. It appears to 'hiccup' on step 5.

I probably need to delete a previously used array or something. I will let you know after some sleep.


----------



## cspengel (Nov 25, 2022)

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



```
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
```


----------



## cspengel (Dec 14, 2022)

johnnyL said:


> I will have to take a closer look at the code I have come up with. It appears to 'hiccup' on step 5.
> 
> I probably need to delete a previously used array or something. I will let you know after some sleep.


Alright sounds good thanks! Goodnight


----------



## cspengel (Dec 15, 2022)

So after adding a debug.Print for the Columns and Rows of the array UniqueUnsortedRowsArray I think I understand the problem.


```
Debug.Print UBound(UniqueUnSortedRowsArray, 1)
Debug.Print UBound(UniqueUnSortedRowsArray, 2)
```

When 3,872,000 combinations are ran, 981,330 rows by 10 columns is remaining after the removal of duplicates and are printed to this sheet->then it moves to step 4 where it begins the process of removing based on salary. After rows with salary over 60k are removed, 241,673  printed.

When 4,356,000 combinations are ran,  1,086,520 rows by 10 columns are remaining after the removal of duplicates, which is obviously over the max rows by 37,944 rows and therefore cannot resize the array and print to sheet, so it errors out.

I suppose I did not realize how many rows remained after the duplicates were removed and was more concentrated on what was printed thinking there was more space.

The only way I see to be able to add more combinations is to somehow split UniqueUnsortedRowsArray at 1 million rows. So you would have i.e UniqueUnsortedArray1 and UniqueUnsortedArray2. So once 1million rows is reached, print UniqueUnsortedArray1, remove based on salary. Then Erase that array. Then Print UniqueUnsortedArray2 at the last row used , and remove based on salary.  Not even sure if that's possible, just kind of throwing out random ideas I read . I realize you have the MaxRowsPerSubArray, & I am not sure if that can be used somehow.

At this point, I am certainly grateful enough to be able to run  3,872,000 combos & in (25 min) and can certainly make this work for my needs. I appreciate all you've done thus far.[/CODE]


----------



## johnnyL (Dec 16, 2022)

Does this sound about right?


```
Create all combinations & remove rows with duplicate entries in the same row, leaving 2021760 rows, completed in 00:01:19
Sorting remaining combination rows alphabetically by row completed in 00:07:08
Removal of duplicate sorted rows, leaving 859249 rows, completed in 00:04:11
Restore of Original order of names in the remaining combinations completed in 00:00:07
Remove all combinations with salaries > 60000, leaving 364253 rows, completed in 00:02:37
Wrapping up completed in 00:02:26
3144960  possible combinations
364253   unique name combinations
364253   printed.

00:17:48 to process.
```


----------



## cspengel (Dec 16, 2022)

johnnyL said:


> Does this sound about right?
> 
> 
> ```
> ...


Yes that sounds about right!


----------



## johnnyL (Dec 16, 2022)

Ok, try the following:


```
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 NameCombosV16b()
    'https://www.mrexcel.com/forum/excel-questions/1106189-all-combinations-multiple-columns-without-duplicates.html
'
    Dim bFoundSalary                    As Boolean
    Dim bShowError                      As Boolean
    Dim ComboID_Display                 As Boolean
    Dim dteStart                        As Date
    Dim StartTime                       As Date
    Dim ArrayRow                        As Long, ArrayColumn                    As Long
    Dim ColumnA_Row                     As Long, ColumnB_Row                    As Long, ColumnC_Row                    As Long
    Dim ColumnD_Row                     As Long, ColumnE_Row                    As Long, ColumnF_Row                    As Long
    Dim ColumnG_Row                     As Long, ColumnH_Row                    As Long, ColumnI_Row                    As Long
    Dim CurrentRow                      As Long
    Dim lLastRow                        As Long
    Dim lColumnIndex                    As Long
    Dim lFirstHSortColumn               As Long, lFirstHSortColumn2             As Long
    Dim lFirstHTeamCol                  As Long, lLastHTeamCol                  As Long
    Dim lFirstWriteColumn               As Long, lLastWriteColumn               As Long
    Dim lIndex                          As Long
    Dim lIterationCount                 As Long, lLastIteration                 As Long
    Dim lLastColumn                     As Long
    Dim lLastHSortColumn                As Long, lLastHSortColumn2              As Long
    Dim lLastSalaryRow                  As Long
    Dim lLastUsedColumn                 As Long
    Dim lWriteRow                       As Long
    Dim MaxSalaryAllowed                As Long
    Dim SubArrayNumber                  As Long
    Dim SubArrayColumn                  As Long, SubArrayRow                    As Long
    Dim SubArrays                       As Long
    Dim UniqueArrayRow                  As Long
    Dim oSD                             As Object
    Dim cel                             As Range
    Dim rngFormulaRange                 As Range
    Dim rngReplace                      As Range, rngReplace2                   As Range, rngReplace3                   As Range
    Dim rngSortRange                    As Range
    Dim SortRowRange                    As Range
    Dim WorksheetNameRange              As Range
    Dim Delimiter                       As String
    Dim oSD_KeyString                   As String
    Dim sErrorMsg                       As String
    Dim sMissingSalary                  As String
    Dim sOutput                         As String
    Dim arrOut()                        As Variant
    Dim aryDeDupe                       As Variant
    Dim aryNames                        As Variant
    Dim JaggedArray()                   As Variant
    Dim NoDupeRowArray()                As Variant
    Dim NoDupeSortedRowsArray()         As Variant
    Dim SalaryCalculationArray          As Variant, SalaryCalcShortenedArray()  As Variant
    Dim SalarySheetFullArray            As Variant, SalarySheetShortenedArray() As Variant
    Dim TempArray                       As Variant
    Dim UniqueWorksheetNamesArray       As Variant
    Dim varK                            As Variant
    Dim WorksheetArray                  As Variant
    Dim WorksheetColumnArray()          As Variant
    Dim names                           As Worksheet
    Dim wks                             As Worksheet
    Dim wksData                         As Worksheet
'
    Const MaxCombinationRows            As Long = 40000                                                                        ' <--- Set the MaxCombinationRows to be generated at a time
    Const MaxNoDupeRowArrayRows         As Long = 2100000                                                                       ' <--- Set the Max # rows we will possibly need
    Const MaxRowsPerSubArray            As Long = 40000                                                                        ' <--- Set the MaxRowsPerSubArray
'
    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
'
''    cel.ClearContents
'
    'Any names not accounted for?
    If oSD.Count <> 0 Then
        varK = oSD.keys
'
        For lIndex = LBound(varK) To UBound(varK)
            sMissingSalary = sMissingSalary & ", " & varK(lIndex)
        Next
'
        sMissingSalary = Mid(sMissingSalary, 3)
'
        sOutput = "The following names on the main worksheet do not have a corresponding entry on the 'Salary' worksheet." & vbLf & vbLf & sMissingSalary
'
        MsgBox sOutput
        Debug.Print sOutput
'
        GoTo End_Sub
    End If
'
    Set oSD = CreateObject("Scripting.Dictionary")                                                          ' Erase contents of dictionary
    Set oSD = Nothing                                                                                       ' Delete the dictionary
'
    sErrorMsg = "Ensure a Worksheet is active with a header row starting in A1" & "and names under each header entry."
'
    If TypeName(ActiveSheet) <> "Worksheet" Then
        bShowError = True
    End If
'
    If bShowError Then
        MsgBox sErrorMsg, , "Problems Found in Data"
'
        GoTo End_Sub
    End If
'
    lLastColumn = Range("A1").CurrentRegion.Columns.Count
    lLastUsedColumn = ActiveSheet.UsedRange.Columns.Count
    ReDim aryNames(1 To 2, 1 To lLastColumn)                '1 holds the in-use entry row
'
    'How many combinations? (Order does not matter)
    lLastIteration = 1
'
    For lColumnIndex = 1 To lLastColumn
        aryNames(1, lColumnIndex) = 2
        aryNames(2, lColumnIndex) = Cells(Rows.Count, lColumnIndex).End(xlUp).Row
        lLastIteration = lLastIteration * (aryNames(2, lColumnIndex) - 1)
    Next
'
    Erase aryNames
'
    lFirstWriteColumn = lLastColumn + 2
    lLastWriteColumn = (2 * lLastColumn) + 1
'
    Select Case MsgBox("Process a " & lLastColumn & " column table with " & _
        lLastIteration & " possible combinations?" & vbLf & vbLf & _
        "WARNING: Columns right of the input range will be erased before continuing.", vbOKCancel + vbExclamation + _
        vbDefaultButton2, "Process table?")
'
        Case vbCancel
            GoTo End_Sub
    End Select
'
'-------------------------------------------------------------------------------------------------------------------------------
'
' 2) Clear all columns to the right of Column I on the "Worksheet" sheet. Copy headers from A1:I1 on the "Worksheet" sheet to K1:S1 on the "Worksheet" sheet.
'    Add header "ComboID" to T1 on the "Worksheet" sheet. Create the combinations & if there are no duplicate names in the same combination row then write the
'    combination of names & lIterationCount to NoDupeRowArray.
'
    dteStart = Now()
    StartTime = Now()
'
    Application.StatusBar = "Step 1 of 6 ... Calculating name combinations & saving combinations with no duplicate names in same combination ..."
    DoEvents
'
    'Clear all columns right of input range
    If lLastUsedColumn > lLastColumn Then
        Range(Cells(1, lLastColumn + 1), Cells(1, lLastUsedColumn)).EntireColumn.ClearContents
    End If
'
' Save Worksheet data into 2D 1 based WorksheetArray
    Set WorksheetNameRange = wksData.Range("A2:" & Split(Cells(1, lLastColumn).Address, "$")(1) & _
            wksData.Range("A1").CurrentRegion.Find("*", , xlFormulas, , xlByRows, xlPrevious).Row)
    WorksheetArray = WorksheetNameRange
'
    Cells(1, lLastWriteColumn + 1).Value = "ComboID"
'
    'Add Output Header
    Range(Cells(1, 1), Cells(1, lLastColumn)).Copy Destination:=Cells(1, lFirstWriteColumn)
'
' Load data from 'Worksheet', each column of data will be loaded into a separate array
    ReDim WorksheetColumnArray(1 To lLastColumn)                                                            ' Set the # of arrays in 'jagged' array WorksheetColumnArray
'
    For ArrayColumn = 1 To lLastColumn                                                                      ' Loop through the columns of 'Worksheet'
        lLastRow = Cells(Rows.Count, ArrayColumn).End(xlUp).Row                                             '   Get LastRow of the column
'
        ReDim TempArray(1 To lLastRow - 1, 1 To 1)                                                          '   Set the rows & columns of 2D 1 based TempArray
        WorksheetColumnArray(ArrayColumn) = TempArray                                                       '   Copy the empty 2D 1 based TempArray to WorksheetColumnArray()
'
        For ArrayRow = 1 To lLastRow - 1                                                                    '   Loop through the rows of data in the column
            WorksheetColumnArray(ArrayColumn)(ArrayRow, 1) = WorksheetArray(ArrayRow, ArrayColumn)          '       Save the data to WorksheetColumnArray()
        Next                                                                                                '   Loop back
    Next                                                                                                    ' Loop back
'
    'Start creating combinations
    lIterationCount = 0                                                                                     ' Reset lIterationCount
    lWriteRow = 0                                                                                           ' Reset lWriteRow
    CurrentRow = 0                                                                                          ' Reset WriteRow
'
    ReDim TempArray(1 To MaxCombinationRows, 1 To lLastColumn + 2)                                          ' Set up TempArray with rows = MaxCombinationRows & columns 2 more than data range
    ReDim NoDupeRowArray(1 To MaxNoDupeRowArrayRows, 1 To UBound(TempArray, 2) - 1)                         ' Set the # of rows/columns for NoDupeRowArray
'
    For ColumnA_Row = 1 To UBound(WorksheetColumnArray(1), 1)                                               ' Loop through rows of WorksheetColumnArray(1) ... Column A
        For ColumnB_Row = 1 To UBound(WorksheetColumnArray(2), 1)                                           '   Loop through rows of WorksheetColumnArray(2) ... Column B
            For ColumnC_Row = 1 To UBound(WorksheetColumnArray(3), 1)                                       '       Loop through rows of WorksheetColumnArray(3) ... Column C
                For ColumnD_Row = 1 To UBound(WorksheetColumnArray(4), 1)                                   '           Loop through rows of WorksheetColumnArray(4) ... Column D
                    For ColumnE_Row = 1 To UBound(WorksheetColumnArray(5), 1)                               '               Loop through rows of WorksheetColumnArray(5) ... Column E
                        For ColumnF_Row = 1 To UBound(WorksheetColumnArray(6), 1)                           '                   Loop through rows of WorksheetColumnArray(6) ... Column F
                            For ColumnG_Row = 1 To UBound(WorksheetColumnArray(7), 1)                       '                       Loop through rows of WorksheetColumnArray(7) ... Column G
                                For ColumnH_Row = 1 To UBound(WorksheetColumnArray(8), 1)                   '                           Loop through rows of WorksheetColumnArray(8) ... Column H
                                    For ColumnI_Row = 1 To UBound(WorksheetColumnArray(9), 1)               '                               Loop through rows of WorksheetColumnArray(9) ... Column I
                                        lIterationCount = lIterationCount + 1                               '                                   Increment lIterationCount
'
' Point to the next blank row in the NoDupeRowArray
                                        lWriteRow = lWriteRow + 1                                           '                                   Increment lWriteRow for TempArray
'
' Save the combination & ComboID to TempArray
                                        TempArray(lWriteRow, 1) = WorksheetColumnArray(1)(ColumnA_Row, 1)   '                                   Save name from column A to TempArray
                                        TempArray(lWriteRow, 2) = WorksheetColumnArray(2)(ColumnB_Row, 1)   '                                   Save name from column B to TempArray
                                        TempArray(lWriteRow, 3) = WorksheetColumnArray(3)(ColumnC_Row, 1)   '                                   Save name from column C to TempArray
                                        TempArray(lWriteRow, 4) = WorksheetColumnArray(4)(ColumnD_Row, 1)   '                                   Save name from column D to TempArray
                                        TempArray(lWriteRow, 5) = WorksheetColumnArray(5)(ColumnE_Row, 1)   '                                   Save name from column E to TempArray
                                        TempArray(lWriteRow, 6) = WorksheetColumnArray(6)(ColumnF_Row, 1)   '                                   Save name from column F to TempArray
                                        TempArray(lWriteRow, 7) = WorksheetColumnArray(7)(ColumnG_Row, 1)   '                                   Save name from column G to TempArray
                                        TempArray(lWriteRow, 8) = WorksheetColumnArray(8)(ColumnH_Row, 1)   '                                   Save name from column H to TempArray
                                        TempArray(lWriteRow, 9) = WorksheetColumnArray(9)(ColumnI_Row, 1)   '                                   Save name from column I to TempArray
'
                                        TempArray(lWriteRow, lLastColumn + 1) = lIterationCount             '                                   Save lIterationCount to TempArray
'
                                        If lWriteRow = MaxCombinationRows Then                              '                                   If we have written MaxCombinationRows to TempArray then ...
                                            ActiveSheet.Cells(2, lFirstWriteColumn).Resize(UBound(TempArray, 1), _
                                                    UBound(TempArray, 2)) = TempArray                       '                                       Write the TempArray to the sheet
'
                                            lLastRow = Cells(Rows.Count, lFirstWriteColumn).End(xlUp).Row   '                                       Get lLastRow
                                            lLastUsedColumn = ActiveSheet.UsedRange.Columns.Count           '                                       Get LastUsedColumn in the sheet
' Add formula to each row
                                            Set rngFormulaRange = Range(Cells(2, lLastUsedColumn + 1), _
                                                    Cells(lLastRow, lLastUsedColumn + 1))                   '                                       Set the Range to place formulas in
'
                                            With rngFormulaRange
                                                .Formula = "=MODE.MULT(MATCH($" & Split(Cells(1, lFirstWriteColumn).Address, "$")(1) & "2:$" & _
                                                        Split(Cells(1, lLastUsedColumn).Address, "$")(1) & "2,$" & _
                                                        Split(Cells(1, lFirstWriteColumn).Address, "$")(1) & "2:$" & _
                                                        Split(Cells(1, lLastUsedColumn).Address, "$")(1) & "2,0))"  '                                   Formula to check for duplicates in same row
                                                Application.Calculate                                       '
                                                .Value = .Value                                             '
                                            End With
'
' Load the data with formula results back into TempArray
                                            TempArray = ActiveSheet.Cells(2, lFirstWriteColumn).Resize(UBound(TempArray, 1), _
                                                    UBound(TempArray, 2))                                   '
'
                                            For ArrayRow = 1 To UBound(TempArray, 1)                        '                                       Loop through rows of TempArray
                                                If Application.WorksheetFunction.IsNA(TempArray(ArrayRow, _
                                                        UBound(TempArray, 2))) Then                         '                                           If formula resulted in '#N/A' then ...
                                                    CurrentRow = CurrentRow + 1                             '                                               Increment CurrentRow, this is the
'                                                                                                           '                                                       row of the NoDupeRowArray
'
                                                    For ArrayColumn = 1 To UBound(TempArray, 2) - 1         '                                               Loop through columns of
'                                                                                                           '                                                       TempArray, except last column
                                                        NoDupeRowArray(CurrentRow, ArrayColumn) = _
                                                                TempArray(ArrayRow, ArrayColumn)            '                                                   Save values to NoDupeRowArray
                                                    Next                                                    '                                               Loop back
                                                End If
                                            Next                                                            '                                       Loop back
'
                                            lWriteRow = 0                                                   '                                       Reset lWriteRow for TempArray
'
                                            ActiveSheet.Cells(2, lFirstWriteColumn).Resize(UBound(TempArray, 1), _
                                                    UBound(TempArray, 2)).ClearContents                     '                                       Clear the data range
'
                                            ReDim TempArray(1 To MaxCombinationRows, 1 To lLastColumn + 2)  '                                       Clear results from TempArray
                                        End If
                                    Next                                                                    '                               Loop back
                                Next                                                                        '                           Loop back
                            Next                                                                            '                       Loop back
                        Next                                                                                '                   Loop back
                    Next                                                                                    '               Loop back
                Next                                                                                        '           Loop back
            Next                                                                                            '       Loop back
        Next                                                                                                '   Loop back
    Next                                                                                                    ' Loop back
'
    Erase WorksheetColumnArray
'
    If TempArray(1, 1) <> vbNullString Then                                                                 ' If there are more cominations needing to be checked then ...
        ActiveSheet.Cells(2, lFirstWriteColumn).Resize(UBound(TempArray, 1), UBound(TempArray, 2)) = TempArray  '   Write the TempArray to the sheet
'
        lLastRow = Cells(Rows.Count, lFirstWriteColumn).End(xlUp).Row                                       '   Get lLastRow
        lLastUsedColumn = ActiveSheet.UsedRange.Columns.Count                                               '   Get LastUsedColumn in the sheet
'
' Add formula to each row
        Set rngFormulaRange = Range(Cells(2, lLastUsedColumn + 1), _
                Cells(lLastRow, lLastUsedColumn + 1))                                                       '   Set the Range to place formulas
'
        With rngFormulaRange
            .Formula = "=MODE.MULT(MATCH($" & Split(Cells(1, lFirstWriteColumn).Address, "$")(1) & "2:$" & _
                    Split(Cells(1, lLastUsedColumn).Address, "$")(1) & "2,$" & _
                    Split(Cells(1, lFirstWriteColumn).Address, "$")(1) & "2:$" & _
                    Split(Cells(1, lLastUsedColumn).Address, "$")(1) & "2,0))"                              '       Formula to check for duplicates in same row
            Application.Calculate                                                                           '
            .Value = .Value                                                                                 '
        End With
'
    Set rngFormulaRange = Nothing
'
' Load the data with formula results back into TempArray
        TempArray = ActiveSheet.Cells(2, lFirstWriteColumn).Resize(UBound(TempArray, 1), UBound(TempArray, 2))  '
'
        For ArrayRow = 1 To UBound(TempArray, 1)                                                            '   Loop through rows of TempArray
            If Application.WorksheetFunction.IsNA(TempArray(ArrayRow, UBound(TempArray, 2))) Then           '       If formula resulted in '#N/A' ( No duplicates in row) then ...
                CurrentRow = CurrentRow + 1                                                                 '           Increment CurrentRow, this is the row of the NoDupeRowArray
'
                For ArrayColumn = 1 To UBound(TempArray, 2) - 1                                             '           Loop through columns of TempArray, except last column
                    NoDupeRowArray(CurrentRow, ArrayColumn) = TempArray(ArrayRow, ArrayColumn)              '               Save values to NoDupeRowArray
                Next                                                                                        '           Loop back
            End If
        Next                                                                                                '   Loop back
'
        ActiveSheet.Cells(2, lFirstWriteColumn).Resize(UBound(TempArray, 1), UBound(TempArray, 2)).ClearContents    '   Clear the data range
    End If
'
    Erase TempArray                                                                                         '
'
    NoDupeRowArray = ReDimPreserve(NoDupeRowArray, CurrentRow, UBound(NoDupeRowArray, 2))                       ' Resize NoDupeRowArray to correct the actual rows used in the array
'
    Debug.Print "Create all combinations & remove rows with duplicate entries in the same row, leaving " & _
            UBound(NoDupeRowArray, 1) & " rows, completed in " & Format(Now() - StartTime, "hh:mm:ss")      ' Display elapsed time for this process to the 'Immediate' window (CTRL+G) in VBE
'
' At this point, NoDupeRowArray(1 thru 9) = names in original order, 10 = ComboID
'
'-------------------------------------------------------------------------------------------------------------------------------
'
' 3) Create a 'jagged array', which is just an array of arrays, of the remaining combinations. This us what allows us to handle
'       larger amounts of combinations. Instead of trying to write them all to the sheet for sorting, we will use the jagged array
'       to write amounts of combinations to the sheet that doesn't exceed the maximum amount of rows that Excel allows. We then
'       sort those rows & save the result back to the jagged array subArray, clear the sheet, write the next subArray to the sheet, sort the data,
'       save it back to the jagged array, etc.
'
    StartTime = Now()
'
    Application.StatusBar = "Step 2 of 6 ... Sorting remaining combination rows alphabetically by row ..."
    DoEvents
'
    SubArrays = Int((UBound(NoDupeRowArray, 1) - 1) / MaxRowsPerSubArray) + 1                               ' Determine number of SubArrays needed
'
    ReDim JaggedArray(1 To SubArrays)                                                                       ' Set the # of SubArrays in JaggedArray
'
    CurrentRow = 0                                                                                          ' Reset CurrentRow
'
' Create array(s) of combinations
    For SubArrayNumber = 1 To SubArrays                                                                     ' Loop through SubArrays
        ReDim arrOut(1 To MaxRowsPerSubArray, 1 To UBound(NoDupeRowArray, 2))                               '   Reset the arrOut
'
        For SubArrayRow = 1 To MaxRowsPerSubArray                                                           '   Loop through rows of arrOut
            CurrentRow = CurrentRow + 1                                                                     '       Increment CurrentRow, this is the row of the NoDupeRowArray
'
            If CurrentRow > UBound(NoDupeRowArray, 1) Then Exit For                                         '       If all of the rows have been processed then exit this For loop
'
            For ArrayColumn = 1 To UBound(NoDupeRowArray, 2)                                                '       Loop through columns of NoDupeRowArray
                arrOut(SubArrayRow, ArrayColumn) = NoDupeRowArray(CurrentRow, ArrayColumn)                      '           Save column value into arrOut
            Next                                                                                            '       Loop back
        Next                                                                                                '   Loop back
'
        JaggedArray(SubArrayNumber) = arrOut                                                                '   Save the arrOut to the JaggedArray
'
        Erase arrOut                                                                                        '
    Next                                                                                                    ' Loop back
'
' At this point, all of the remaining combinations have been loaded into the JaggedArray subArrays
'
' Write each subArray to the sheet, sort each row & save results back into the subArray
    For SubArrayNumber = 1 To SubArrays                                                                     ' Loop through SubArrays
        ActiveSheet.Cells(2, lFirstWriteColumn).Resize(UBound(JaggedArray(SubArrayNumber), 1), _
                UBound(JaggedArray(SubArrayNumber), 2)) = JaggedArray(SubArrayNumber)                       '   Write the subArray to the sheet for sorting
'
        ActiveSheet.Sort.SortFields.Clear                                                                   '
'
' Sort each row
        lLastRow = Cells(Rows.Count, lFirstWriteColumn).End(xlUp).Row                                       '   Get lLastRow
'
        Set rngSortRange = Range(Cells(2, lFirstWriteColumn), Cells(lLastRow, lLastWriteColumn + 1))        '   Set the Range to be sorted
'
        For Each SortRowRange In rngSortRange.Rows                                                          '   Loop through each row of the range to be sorted
            SortRowRange.Sort Key1:=SortRowRange.Cells(1, 1), Order1:=xlAscending, _
                    Header:=xlNo, Orientation:=xlSortRows                                                   '       Sort each row alphabetically
        Next                                                                                                '   Loop back
'
    Set rngSortRange = Nothing
    Set SortRowRange = Nothing
'
' Load the sorted data back into the subArray
        JaggedArray(SubArrayNumber) = ActiveSheet.Cells(2, lFirstWriteColumn).Resize(UBound(JaggedArray(SubArrayNumber), 1), _
                UBound(JaggedArray(SubArrayNumber), 2))                                                     '
'
        ActiveSheet.Cells(2, lFirstWriteColumn).Resize(UBound(JaggedArray(SubArrayNumber), 1), _
                UBound(JaggedArray(SubArrayNumber), 2)).ClearContents                                       '   Clear the sort range
    Next                                                                                                    ' Loop back
'
    Debug.Print "Sorting remaining combination rows alphabetically by row completed " & _
            "in " & 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 (ComboID) in column 1 and the sorted names in columns 2 thru 10 due to the sorting ;)
'
'-------------------------------------------------------------------------------------------------------------------------------
'
' 4) Copy unique sorted rows from the subArrays to NoDupeSortedRowsArray
'
    StartTime = Now()
'
    Application.StatusBar = "Step 3 of 6 ... Removing duplicate sorted rows ..."
    DoEvents
'
' Join all of the sorted subArray unique rows back into 1 large array
    ReDim NoDupeSortedRowsArray(1 To UBound(NoDupeRowArray, 1), 1 To UBound(NoDupeRowArray, 2))             '
'
    'Initialize the scripting dictionary
    Set oSD = CreateObject("Scripting.Dictionary")
    oSD.CompareMode = vbTextCompare
'
    CurrentRow = 0                                                                                          ' Reset CurrentRow
'
    For SubArrayNumber = 1 To SubArrays                                                                     ' Loop through the SubArrays
        For SubArrayRow = 1 To UBound(JaggedArray(SubArrayNumber), 1)                                       '   Loop through rows of each subArray in the JaggedArray
            oSD_KeyString = ""                                                                              '   Erase 'oSD_KeyString'
            Delimiter = ""                                                                                  '   Erase 'Delimiter' of NoDupeSortedRowsArray
'
            For SubArrayColumn = 2 To UBound(JaggedArray(SubArrayNumber), 2)                                '       Loop through columns, except ComboID (first) column, of
'                                                                                                           '               JaggedArray(SubArrayNumber)
                oSD_KeyString = oSD_KeyString & Delimiter & JaggedArray(SubArrayNumber)(SubArrayRow, SubArrayColumn)    '       Save data from JaggedArray(SubArrayNumber) row, separated
'                                                                                                           '                           by Delimiter, into oSD_KeyString
                Delimiter = Chr(2)
            Next                                                                                            '   Loop back
'
            If Not oSD.Exists(oSD_KeyString) Then                                                           '   If this is a unique sorted name row then ...
                oSD.Add oSD_KeyString, ""                                                                   '       Add it to the dictionary
'
                CurrentRow = CurrentRow + 1                                                                 '       Increment CurrentRow
'
                For ArrayColumn = 2 To UBound(JaggedArray(SubArrayNumber), 2)                               '           Loop through columns of JaggedArray(SubArrayNumber)
                    NoDupeSortedRowsArray(CurrentRow, ArrayColumn - 1) = JaggedArray(SubArrayNumber)(SubArrayRow, ArrayColumn)  '               Save values to NoDupeRowArray
                Next                                                                                        '           Loop back
'
                NoDupeSortedRowsArray(CurrentRow, UBound(JaggedArray(SubArrayNumber), 2)) = JaggedArray(SubArrayNumber)(SubArrayRow, 1) '           Save ComboID to NoDupeSortedRowsArray
            End If
        Next                                                                                                '   Loop back
'
        Erase JaggedArray(SubArrayNumber)                                                                   '
    Next                                                                                                    ' Loop back
'
    Erase JaggedArray
'
    Set oSD = CreateObject("Scripting.Dictionary")                                                          ' Erase contents of dictionary
    Set oSD = Nothing                                                                                       ' Delete the dictionary
'
    NoDupeSortedRowsArray = ReDimPreserve(NoDupeSortedRowsArray, CurrentRow, UBound(NoDupeSortedRowsArray, 2))  ' Resize NoDupeSortedRowsArray to correct the actual rows used in the array
'
    Debug.Print "Removal of duplicate sorted rows, leaving " & UBound(NoDupeSortedRowsArray, 1) & _
            " rows, completed in " & Format(Now() - StartTime, "hh:mm:ss")                                  ' Display elapsed time for this process to the 'Immediate' window (CTRL+G) in VBE
'
' At this point, the unique sorted rows have been written to NoDupeSortedRowsArray &
'   NoDupeSortedRowsArray(1 thru 9) = names in sorted order, 10 = ComboID
'
'-------------------------------------------------------------------------------------------------------
'
' 5) Now we need to match the ComboID in NoDupeSortedRowsArray to the ComboID in NoDupeRowArray so we can
'       put the names for that row back to the original order
'
    StartTime = Now()
'
    Application.StatusBar = "Step 4 of 6 ... Restoring original name order in the sorted rows ..."
    DoEvents
'
    CurrentRow = 1                                                                                          ' Initialize CurrentRow
'
    For ArrayRow = LBound(NoDupeRowArray, 1) To UBound(NoDupeRowArray, 1)                                   ' Loop through rows of NoDupeRowArray
        If CurrentRow > UBound(NoDupeSortedRowsArray, 1) Then Exit For                                      '   If we have processed all rows then exit this For loop
'
        If NoDupeSortedRowsArray(CurrentRow, UBound(NoDupeSortedRowsArray, 2)) = _
                NoDupeRowArray(ArrayRow, UBound(NoDupeRowArray, 2)) Then                                    '   If we found matching ComboID's then ...
'
            For ArrayColumn = LBound(NoDupeRowArray, 2) To UBound(NoDupeRowArray, 2) - 1                    '       Loop through the columns of NoDupeRowArray except for the last column
                NoDupeSortedRowsArray(CurrentRow, ArrayColumn) = NoDupeRowArray(ArrayRow, ArrayColumn)      '           Save the name from the row/column to NoDupeSortedRowsArray
            Next                                                                                            '       Loop back
'
            CurrentRow = CurrentRow + 1                                                                     '       Increment CurrentRow
        End If
    Next                                                                                                    ' Loop back
'
    Erase NoDupeRowArray                                                                                    '
'
    wksData.Cells(2, lFirstWriteColumn).Resize(UBound(NoDupeSortedRowsArray, 1), _
            UBound(NoDupeSortedRowsArray, 2)) = NoDupeSortedRowsArray                                       ' Display NoDupeSortedRowsArray to 'Worksheet'
'
    Debug.Print "Restore of Original order of names in the remaining combinations completed in " & _
            Format(Now() - StartTime, "hh:mm:ss")                                                           ' Display elapsed time for this process to the 'Immediate' window (CTRL+G) in VBE
'
' At this point, NoDupeSortedRowsArray(1 thru 9) = names in original order, 10 = ComboID
'
'-------------------------------------------------------------------------------------------------------
'
' 6) Copy data on sheet to next set of columns. Insert a column for the salary total of each row. Save the unique
'       names from the 'Worksheet' into UniqueWorksheetNamesArray. Save respective data from 'Salary' sheet into
'       SalarySheetShortenedArray. Replace copied names in column U:AC with the players respective
'       salary data in SalarySheetShortenedArray. Sum the salaries from each of those rows & save results into
'       the added Salary column.
'
    StartTime = Now()
'
    Application.StatusBar = "Step 5 of 6 ... Removing all combination rows with salaries > " & MaxSalaryAllowed & " ..."    '
    DoEvents                                                                                                '
'
    lLastRow = Cells(Rows.Count, lFirstWriteColumn).End(xlUp).Row                                           '
'
    Range(Cells(1, lFirstWriteColumn), Cells(lLastRow, lLastWriteColumn + 1)).Copy _
            Destination:=Cells(1, lLastWriteColumn + 2)                                                     ' Rows for SALARY ... Copy K1:T & lLastRow to U1:AD & lLastRow
    lFirstHSortColumn = lLastWriteColumn + 2                                                                ' 21 ie. column U
    lLastHSortColumn = Cells(1, Columns.Count).End(xlToLeft).Column + 1                                     ' 31 ie. column AE
'
    Columns(lLastHSortColumn - 1).Insert                                                                    ' Insert column AD for the 'Salary'
'
    With Worksheets("Salary") '''' SALARY
        lLastSalaryRow = .Cells(.Rows.Count, 1).End(xlUp).Row                                               '
    End With
'
    With CreateObject("scripting.dictionary")
        .CompareMode = vbTextCompare                                                                        '
'
        For Each cel In WorksheetNameRange                                                                  '   Loop through each cell in the WorksheetNameRange
            If cel <> "" Then                                                                               '       If the cell is not blank then ...
                If Not .Exists(cel.Value) Then                                                              '           If the value has not already been saved then ...
                    .Add cel.Value, cel.Value                                                               '               Save the value
                End If
            End If
'
            UniqueWorksheetNamesArray = Application.Transpose(Array(.keys))                                 '       Transpose results to 2D 1 based UniqueWorksheetNamesArray
        Next                                                                                                '   Loop back
    End With
'
    Set WorksheetNameRange = Nothing
    Set cel = Nothing
'
    SalarySheetFullArray = names.Range("A2:" & _
            Split(Cells(names.Cells.Find("*", , xlFormulas, , xlByColumns, xlPrevious).Column).Address, "$")(1) & lLastSalaryRow)   ' Save all of the data from the 'Salary' aheet into 2D 1 based SalarySheetFullArray
'
    ReDim SalarySheetShortenedArray(1 To UBound(SalarySheetFullArray, 1), 1 To UBound(SalarySheetFullArray, 2)) ' Set 2D 1 based SalarySheetShortenedArray to the same size as SalarySheetFullArray
'
    CurrentRow = 0                                                                                          ' Initialize CurrentRow
'
    For UniqueArrayRow = 1 To UBound(UniqueWorksheetNamesArray, 1)                                          ' Loop through the rows of UniqueWorksheetNamesArray
        For ArrayRow = 1 To UBound(SalarySheetFullArray, 1)                                                 '   Loop through the rows of SalarySheetFullArray
            If UniqueWorksheetNamesArray(UniqueArrayRow, 1) = SalarySheetFullArray(ArrayRow, 1) Then        '       If the name from UniqueWorksheetNamesArray is found in SalarySheetFullArray then ...
                CurrentRow = CurrentRow + 1                                                                 '           Increment CurrentRow
'
                For lColumnIndex = 1 To UBound(SalarySheetFullArray, 2)                                             '           Loop through the columns of SalarySheetFullArray
                    SalarySheetShortenedArray(CurrentRow, lColumnIndex) = SalarySheetFullArray(ArrayRow, lColumnIndex)  '               Save the values to SalarySheetShortenedArray
                Next                                                                                                '           Loop back
            End If
        Next                                                                                                '   Loop back
    Next                                                                                                    ' Loop back
'
    Erase SalarySheetFullArray                                                                              '
'
    SalarySheetShortenedArray = ReDimPreserve(SalarySheetShortenedArray, CurrentRow, UBound(SalarySheetShortenedArray, 2))  ' Resize SalarySheetShortenedArray to correct the actual rows used in the array
'
    Set rngReplace = Range(Cells(2, lFirstHSortColumn), Cells(lLastRow, lLastHSortColumn - 2))              '
'
    For ArrayRow = 1 To UBound(SalarySheetShortenedArray, 1)                                               '
        rngReplace.Replace What:=SalarySheetShortenedArray(ArrayRow, 1), _
                Replacement:=SalarySheetShortenedArray(ArrayRow, 2), LookAt:=xlWhole, _
                SearchOrder:=xlByRows, MatchCase:=False, SearchFormat:=False, ReplaceFormat:=False          '
    Next                                                                                                    ' Loop back
'
    Set rngReplace = Nothing
'
' Add Sum Column
    Cells(1, lLastHSortColumn - 1).Value = ChrW(931) & " Salary"                                            ' 30 ... AD
'
    With Range(Cells(2, lLastHSortColumn - 1), Cells(lLastRow, lLastHSortColumn - 1))
        .FormulaR1C1 = "=SUM(RC" & lFirstHSortColumn & ":RC" & lLastHSortColumn - 2 & ")"                   '
        Application.Calculate                                                                               '
        .Value = .Value                                                                                     '
    End With
'
'-------------------------------------------------------------------------------------------------------------------------------
'
' 7) Save the 'Salary' range of data into SalaryCalculationArray. Save allowable salary rows into SalaryCalcShortenedArray.
'       Match the ComboIDs for each row saved to the ComboIDs in NoDupeSortedRowsArray so we can replace the
'       respective names to the salaries.
'
    SalaryCalculationArray = Range(Cells(2, lFirstHSortColumn), Cells(lLastRow, lLastHSortColumn))          '
    ReDim SalaryCalcShortenedArray(1 To UBound(SalaryCalculationArray, 1), _
            1 To UBound(SalaryCalculationArray, 2))                                                         ' Set the # of rows/columns for SalaryCalcShortenedArray
'
    CurrentRow = 0                                                                                          ' Initialize CurrentRow
'
    For ArrayRow = LBound(SalaryCalculationArray, 1) To UBound(SalaryCalculationArray, 1)                   ' Loop through rows of SalaryCalculationArray
        If SalaryCalculationArray(ArrayRow, UBound(SalaryCalculationArray, 2) - 1) <= MaxSalaryAllowed Then '   If we have an allowable salary then ...
            CurrentRow = CurrentRow + 1                                                                     '       Increment CurrentRow
'
            For ArrayColumn = LBound(SalaryCalculationArray, 2) To UBound(SalaryCalculationArray, 2)        '       Loop through the columns of SalaryCalculationArray
                SalaryCalcShortenedArray(CurrentRow, ArrayColumn) = SalaryCalculationArray(ArrayRow, ArrayColumn)   '           Save the data from the row to SalaryCalcShortenedArray
            Next                                                                                            '       Loop back
        End If
    Next                                                                                                    ' Loop back
'
    Erase SalaryCalculationArray                                                                            '
'
    SalaryCalcShortenedArray = ReDimPreserve(SalaryCalcShortenedArray, CurrentRow, UBound(SalaryCalcShortenedArray, 2)) '
'
' Replace the individual Salary amounts with the original individual names by matching up the ComboIDs
    CurrentRow = 1                                                                                          ' Initialize CurrentRow
'
    For ArrayRow = LBound(NoDupeSortedRowsArray, 1) To UBound(NoDupeSortedRowsArray, 1)                     ' Loop through rows of NoDupeSortedRowsArray
        If NoDupeSortedRowsArray(ArrayRow, UBound(NoDupeSortedRowsArray, 2)) = _
                SalaryCalcShortenedArray(CurrentRow, UBound(SalaryCalcShortenedArray, 2)) Then              '   If we found matching ComboID's then ...
            For ArrayColumn = LBound(NoDupeSortedRowsArray, 2) To UBound(NoDupeSortedRowsArray, 2) - 1      '       Loop through the columns of NoDupeSortedRowsArray except for the last column
                SalaryCalcShortenedArray(CurrentRow, ArrayColumn) = NoDupeSortedRowsArray(ArrayRow, ArrayColumn)    '           Save the name from the row/column to SalaryCalcShortenedArray
            Next                                                                                            '       Loop back
'
            CurrentRow = CurrentRow + 1                                                                     '       Increment CurrentRow
'
            If CurrentRow > UBound(SalaryCalcShortenedArray, 1) Then Exit For                               '
        End If
    Next                                                                                                    ' Loop back
'
    Erase NoDupeSortedRowsArray
'
    Range(Columns(lFirstHSortColumn - 1), Columns(lLastHSortColumn - 2)).Delete                             ' Delete columns T:AC ... 20 thru 29
    Range(Cells(2, lFirstWriteColumn), Cells(lLastRow, lFirstHSortColumn)).ClearContents                    ' Erase rest of calculated data from the 'Worksheet'
'
' At this point, all criteria for deletion of combination rows have been completed
'
    Cells(2, lFirstWriteColumn).Resize(UBound(SalaryCalcShortenedArray, 1), _
            UBound(SalaryCalcShortenedArray, 2)) = SalaryCalcShortenedArray                                 ' Display SalaryCalcShortenedArray to 'Worksheet'
'
' We need to swap the last 2 columns (Salary & ComboID)
    Columns(lLastWriteColumn + 1).Insert                                                                    ' Insert a blank column
    Columns(lFirstHSortColumn + 1).Cut Cells(1, lLastWriteColumn + 1)                                       ' Cut/paste the last column into the inserted column
'
    Debug.Print "Remove all combinations with salaries > " & MaxSalaryAllowed & ", leaving " & _
        UBound(SalaryCalcShortenedArray, 1) & " rows, completed in " & Format(Now() - StartTime, "hh:mm:ss")    ' Display elapsed time for this process to the 'Immediate' window (CTRL+G) in VBE
'
    Erase SalaryCalcShortenedArray
'
'-------------------------------------------------------------------------------------------------------------------------------
'
' 8) A projection column is added to column AW. The projections from columns AD:AL are
'    calculated(summed) and entered into column AW. A "Stack" column is added to column AX and the most used team in the combinations are calculated using the
'    MODE function. A "Stack POS" column is added to column AY. The players position - who consisted of the most used team are added to column AY by pulling the
'    column headers associated to the corresponding player using the TEXTJOIN function. A "" Stack2" column is added to the AZ column and a "Stack2 POS" column
'    is added to the BA column - Both using the similar method as first stack column.
'
    StartTime = Now()
'
    Application.StatusBar = "Step 6 of 6 ...Wrapping up ..."
    DoEvents
'
    lLastRow = Cells(Rows.Count, lFirstWriteColumn).End(xlUp).Row                                           '
'
    If lLastRow > 1 Then                                                                                    '
        Range(Cells(1, lFirstWriteColumn), Cells(lLastRow, lLastWriteColumn)).Copy _
                Destination:=Cells(1, lFirstHSortColumn + 1)                                                '   Rows for PROJECTION
'
        lLastHSortColumn2 = Cells(1, Columns.Count).End(xlToLeft).Column                                    '   30 ... AD
'
        Range(Cells(1, lFirstWriteColumn), Cells(lLastRow, lLastWriteColumn)).Copy _
                Destination:=Cells(1, lLastHSortColumn2 + 1)                                                '   Rows for TEAM
'
        lFirstHSortColumn2 = lFirstHSortColumn + 1                                                          '   22 ... V
        lFirstHTeamCol = lLastHSortColumn2 + 1                                                              '   31 ... AE
        lLastHTeamCol = Cells(1, Columns.Count).End(xlToLeft).Column                                        '   39 ... AM
'
        Set rngReplace2 = Range(Cells(2, lFirstHSortColumn2), Cells(lLastRow, lLastHSortColumn2))           '   22 ... V ... 30 ... AD
        Set rngReplace3 = Range(Cells(2, lFirstHTeamCol), Cells(lLastRow, lLastHTeamCol))                   '   31 ... AE ... 39 ... AM
'
        For ArrayRow = 1 To UBound(SalarySheetShortenedArray, 1)                                            '   Loop through rows of SalarySheetShortenedArray
'
'''''''''''''''''''''''''''''''''''''PROJECTION
            rngReplace2.Replace What:=SalarySheetShortenedArray(ArrayRow, 1), _
                Replacement:=SalarySheetShortenedArray(ArrayRow, 3), LookAt:=xlWhole, _
                SearchOrder:=xlByRows, MatchCase:=False, SearchFormat:=False, ReplaceFormat:=False          '
'
'
         '''''''''''''''''''''''''''''''''''''TEAM
            rngReplace3.Replace What:=SalarySheetShortenedArray(ArrayRow, 1), _
                Replacement:=SalarySheetShortenedArray(ArrayRow, 4), LookAt:=xlWhole, _
                SearchOrder:=xlByRows, MatchCase:=False, SearchFormat:=False, ReplaceFormat:=False          '
        Next                                                                                                '   Loop back
'
        Set rngReplace2 = Nothing
        Set rngReplace3 = Nothing
'
' Add Projection Column
        Cells(1, lLastHTeamCol + 1).Value = ChrW(931) & " Projection"                                       '   40 ... AN
' Add Team Stack Column
        Cells(1, lLastHTeamCol + 2).Value = ChrW(931) & " Stack"                                            '   41 ... AO
' Add Team Stack Pos
        Cells(1, lLastHTeamCol + 3).Value = ChrW(931) & " Stack POS"                                        '   42 ... AP
' Add 2nd Team Stack Column
        Cells(1, lLastHTeamCol + 4).Value = ChrW(931) & " Stack2"                                           '   43 ... AQ
' Add 2nd Team Stack Pos
        Cells(1, lLastHTeamCol + 5).Value = ChrW(931) & " Stack2 POS"                                       '   44 ... AR
' Filter 0-1
        Cells(1, lLastHTeamCol + 6).Value = ChrW(931) & " Filter"                                           '   45 ... AS
' Player 1 Filter
        Cells(1, lLastHTeamCol + 7).Value = ChrW(931) & " Player1"                                          '   46 ... AT
' Player 2 Filter
        Cells(1, lLastHTeamCol + 8).Value = ChrW(931) & " Player2"                                          '   47 ... AU
'
        With Range(Cells(2, lLastHTeamCol + 1), Cells(lLastRow, lLastHTeamCol + 1))
            .FormulaR1C1 = "=SUM(RC" & lFirstHSortColumn2 & ":RC" & lLastHSortColumn2 & ")"                 '       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 + 1), Columns(lLastHTeamCol)).Delete                                    ' Delete columns V:AM ... 22 thru 39
'
    If ComboID_Display = False Then Columns(lLastWriteColumn + 1).Delete                                    ' Delete ComboID column if user chose not to see it
'
    ActiveSheet.UsedRange.Columns.AutoFit                                                                   '
'
    sOutput = lLastIteration & vbTab & " possible combinations" & vbLf & lLastRow - 1 & vbTab & _
            " unique name combinations" & vbLf & IIf(lLastRow < lLastRow, lLastRow - lLastRow & vbTab & _
            " duplicate rows removed." & vbLf, "") & lLastRow - 1 & vbTab & " printed." & vbLf & vbLf & _
            Format(Now() - dteStart, "hh:mm:ss") & " to process."                                           '
'
    Debug.Print "Wrapping up completed in " & Format(Now() - StartTime, "hh:mm:ss")                         ' Display elapsed time for this process to the 'Immediate' window (CTRL+G) in VBE
'
    Debug.Print sOutput                                                                                     '
    MsgBox sOutput, , "Output Report"                                                                       '
'
End_Sub:
    Call OptimizeCode_End
End Sub



Public Function ReDimPreserve(ArrayNameToResize, NewRowUbound, NewColumnUbound)
'
' Code inspired by Control Freak
'
' Preserve Original data & LBounds & Redim both dimensions for a 2D array
'
' example usage of the function:
' ArrayName = ReDimPreserve(ArrayName,NewRowSize,NewColumnSize)
' ie.
' InputArray = ReDimPreserve(InputArray,10,20)
'
    Dim NewColumn                   As Long, NewRow                      As Long
    Dim OldColumnLbound             As Long, OldRowLbound                As Long
    Dim OldColumnUbound             As Long, OldRowUbound                As Long
    Dim NewResizedArray()           As Variant
'
    ReDimPreserve = False
'
    If IsArray(ArrayNameToResize) Then                                                                      ' If the variable is an array then ...
           OldRowLbound = LBound(ArrayNameToResize, 1)                                                      '   Save the original row Lbound to OldRowLbound
        OldColumnLbound = LBound(ArrayNameToResize, 2)                                                      '   Save the original column Lbound to OldColumnLbound
'
        ReDim NewResizedArray(OldRowLbound To NewRowUbound, OldColumnLbound To NewColumnUbound)             '   Create a New 2D Array with same Lbounds as the original array
'
        OldRowUbound = UBound(ArrayNameToResize, 1)                                                         '   Save row Ubound of original array
        OldColumnUbound = UBound(ArrayNameToResize, 2)                                                      '   Save column Ubound of original array
'
        For NewRow = OldRowLbound To NewRowUbound                                                           '   Loop through rows of original array
            For NewColumn = OldColumnLbound To NewColumnUbound                                              '       Loop through columns of original array
                If OldRowUbound >= NewRow And OldColumnUbound >= NewColumn Then                             '           If more data to copy then ...
                    NewResizedArray(NewRow, NewColumn) = ArrayNameToResize(NewRow, NewColumn)               '               Append rows/columns to NewResizedArray
                End If
            Next                                                                                            '       Loop back
        Next                                                                                                '   Loop back
'
        Erase ArrayNameToResize                                                                             '   Free up the memory the Original array was taking
'
        If IsArray(NewResizedArray) Then ReDimPreserve = NewResizedArray
    End If
End Function
```


----------



## cspengel (Dec 16, 2022)

Thanks for that Johnny. I still run into issues due to the array of combinations being larger than what excel allows. So I have to redo the test several times to try and figure out how many combinations will be under 1,048,576 rows after the removal of duplicates. My ignorance is going to show in my next post, but I am going to type something up to try and see if it helps me understand and if you can explain anything I missed.


----------



## cspengel (Dec 16, 2022)

TempArray is used to load the combinations of names, which are generated in increments based on what MaxCombinationRows is. After MaxCombinationRows is reached, TempArray is written to Worksheet, and rows without duplicates are marked with an N/A based on the formula. The rows that result an NA are then added to NoDupeRowArray. The data on the sheet is then cleared, TempArray is cleared, and the cycle repeats until there is no more combinations. 

After all combinations have been loaded into NoDupeRowArray, NoDupeRowArray is resized to the amount of columns and rows. 

Based on how many combinations are in NoDupeRowArray, SubArrays are created based on whatever MaxSubArrays is set at. So if There is 1000 combinations in NoDupeRowArray, and MaxSubArrays is 1000 (combinations), then there are 10 SubArrays. Those 10 SubArrays then fill what is the JaggedArray. Each SubArray is then printed to the worksheet by itself, where it is sorted and then loaded back into its' own SubArray. 

 My Question here is: Is each SubArray printed to the sheet by itself, sorted, and loaded back into its array, or is each SubArray printed to the sheet then all SubArrays sorted together, and then loaded back into their SubArray?

My second question is - after the subArray is printed to the sheet, does that empty what is in the array. If it does not, why does the array not need to be erased before the sorted data is loaded back into it?

A new Array is then used called NoDupeSortedRowsArray. This array is resized to the size NoDupeRowArray is. 

Scripting Dictionary is then used to compare text in each column of each SubArray to determine if the names are unique. If they are unique, the row is added into NoDupeSortedRowsArray. NoDupeSortedRowsArray is then resized to match the amount of combinations contained within it. JaggedArray and SubArrays are then erased.

NoDupeSortedRowsArray and NoDupeRowArray combo ID's are compared to reorganize the sorted data as ComboID was in column1. (Need to get it back to last column). The matching columns are then added back into NoDupeSortedRowsArray. 

The range of cells on the worksheet are then resized to the size of NoDupeSortedRowsArray and NoDupeSortedRowsArray is printed to the worksheet.

So if I understand correctly, 

NoDupeRowArray does not contain duplicates in the same row, but may contain duplicates in totality as the combinations may not be unique.

NoDupeSortedRowsArray does not contain duplicates period, as all combinations have been checked both in row and various combinations by sorting. 

The size of NoDupeRowArray is based on what MaxNoDupeRowArrayRows is set too

The constant  MaxNoDupeRowArrayRows  is based on combinations  that still contains duplicates, therefore it needs to be set higher than max rows allowed in excel.

IF the array NoDupeSortedRowsArray is loaded with more than 1,048,576 rows, the macro will fail.  

I guess what I don't understand is what the purpose of  MaxNoDupeRowArrayRows is as the program will still fail when NoDupeSortedRowsArray is loaded with too many combinations. 

If NoDupeSortedRowsArray can be overloaded with combinations, what is the purpose of any of the settings as they cause more errors if set wrong. 

Is there a way to PREVENT NoDupeSortedRows array from being overloaded in the first place? 

Thanks for your help, and I am sure i'm missing something. Just trying to understand if there is a way to only write enough rows and not error out.


----------



## cspengel (Dec 16, 2022)

```

```


----------



## johnnyL (Dec 16, 2022)

cspengel said:


> My Question here is: Is each SubArray printed to the sheet by itself, sorted, and loaded back into its array, or is each SubArray printed to the sheet then all SubArrays sorted together, and then loaded back into their SubArray?
> 
> My second question is - after the subArray is printed to the sheet, does that empty what is in the array. If it does not, why does the array not need to be erased before the sorted data is loaded back into it?


Q1) Each subArray is loaded to the sheet, sorted, and saved back to the subArray.
Q2) When an array is written to the sheet, the data still remains in the array also. When the data is saved back to the array, it is writing the same size of data back to the array so the existing data in the array will be overwritten with the data being saved to the array.




cspengel said:


> I guess what I don't understand is what the purpose of  MaxNoDupeRowArrayRows is as the program will still fail when NoDupeSortedRowsArray is loaded with too many combinations.
> 
> If NoDupeSortedRowsArray can be overloaded with combinations, what is the purpose of any of the settings as they cause more errors if set wrong.
> 
> ...



The purpose of MaxNoDupeRowArrayRows is to set NoDupeRowArray to a size big enough to handle the number of combinations that will remain after step 2 is completed. The larger you assign an array, the larger memory is required.

The arrays are used because they can hold more rows than what the sheet can hold.

I can add one more bit of code to handle the elimination of combinations by the 60000 salary cap. That would reduce the final amount of combinations trying to be written to the sheet. I could also make the code only write up to a certain # of combinations to the sheet & just ditch the rest of the combinations.


----------



## cspengel (Dec 16, 2022)

johnnyL said:


> Q1) Each subArray is loaded to the sheet, sorted, and saved back to the subArray.
> Q2) When an array is written to the sheet, the data still remains in the array also. When the data is saved back to the array, it is writing the same size of data back to the array so the existing data in the array will be overwritten with the data being saved to the array.
> 
> 
> ...


Thank you for that explanation. That would be awesome.

I was trying to mess around with it and create another constant like MaxRowsToSheet and do something like:

If CurrentRows = MaxRowsToSheet Then Exit For to stop it writing to NoDupeSortArrays, but I am doing something wrong. My lack of knowledge is showing


----------



## cspengel (Nov 25, 2022)

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



```
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
```


----------



## johnnyL (Dec 16, 2022)

Ok, the additional code is completed for the 'salary' section.
 I just need to clean up the code and comment it, I also need to add your last stipulation of only printing combinations that will fit on one sheet.

Current result:

```
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.
```


----------



## johnnyL (Dec 17, 2022)

Ok here is the latest result:

```
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.
```

It is up to you for playing with the settings

```
Const MaxCombinationRows            As Long = 80000                                                                        ' <--- Set the MaxCombinationRows (100000) is probaly the max to be generated at a time
    Const MaxNoDupeRowArrayRows         As Long = 2100000                                                                       ' <--- Set the Max # rows we will possibly need
    Const MaxRowsPerSubArray            As Long = 80000                                                                        ' <--- Set the MaxRowsPerSubArray (100000) is probaly the max you would want
'
    ComboID_Display = True                                                                                                      ' <--- Set this to True or False to see/not see the ComboID column
    MaxSalaryAllowed = 60000                                                                                                    ' <--- set this value to what you want
```


This is the code I came up with:

```
Option Explicit

Public EventState       As Boolean
Public PageBreakState   As Boolean
Public CalcState        As Long


Private Sub OptimizeCode_Begin()
'
    With Application
             CalcState = .Calculation
            EventState = .EnableEvents
        PageBreakState = ActiveSheet.DisplayPageBreaks
'
             .StatusBar = False
           .Calculation = xlManual
          .EnableEvents = False
        .ScreenUpdating = False
        ActiveSheet.DisplayPageBreaks = False
    End With
End Sub


Private Sub OptimizeCode_End()
'
    With Application
        ActiveSheet.DisplayPageBreaks = PageBreakState
                        .EnableEvents = EventState
                         .Calculation = CalcState
'
                      .ScreenUpdating = True
                           .StatusBar = False
    End With
End Sub


Sub NameCombosV16c()
    'https://www.mrexcel.com/forum/excel-questions/1106189-all-combinations-multiple-columns-without-duplicates.html
'
    Dim bFoundSalary                    As Boolean
    Dim bShowError                      As Boolean
    Dim ComboID_Display                 As Boolean
    Dim dteStart                        As Date
    Dim StartTime                       As Date
    Dim ArrayRow                        As Long, ArrayColumn                    As Long
    Dim ColumnA_Row                     As Long, ColumnB_Row                    As Long, ColumnC_Row                    As Long
    Dim ColumnD_Row                     As Long, ColumnE_Row                    As Long, ColumnF_Row                    As Long
    Dim ColumnG_Row                     As Long, ColumnH_Row                    As Long, ColumnI_Row                    As Long
    Dim CurrentRow                      As Long
    Dim ExcessCombinations              As Long
    Dim lLastRow                        As Long
    Dim lColumnIndex                    As Long
    Dim lFirstHSortColumn               As Long, lFirstHSortColumn2             As Long
    Dim lFirstHTeamCol                  As Long, lLastHTeamCol                  As Long
    Dim lFirstWriteColumn               As Long, lLastWriteColumn               As Long
    Dim lIndex                          As Long
    Dim lIterationCount                 As Long, lLastIteration                 As Long
    Dim lLastColumn                     As Long
    Dim lLastHSortColumn                As Long, lLastHSortColumn2              As Long
    Dim lLastSalaryRow                  As Long
    Dim lLastUsedColumn                 As Long
    Dim lWriteRow                       As Long
    Dim MaxSalaryAllowed                As Long
    Dim SubArrayNumber                  As Long
    Dim SubArrayColumn                  As Long, SubArrayRow                    As Long
    Dim SubArrays                       As Long
    Dim UniqueArrayRow                  As Long
    Dim oSD                             As Object
    Dim cel                             As Range
    Dim rngFormulaRange                 As Range
    Dim rngReplace                      As Range, rngReplace2                   As Range, rngReplace3                   As Range
    Dim rngSortRange                    As Range
    Dim SortRowRange                    As Range
    Dim WorksheetNameRange              As Range
    Dim Delimiter                       As String
    Dim oSD_KeyString                   As String
    Dim sErrorMsg                       As String
    Dim sMissingSalary                  As String
    Dim sOutput                         As String
    Dim arrOut()                        As Variant
    Dim aryDeDupe                       As Variant
    Dim aryNames                        As Variant
    Dim JaggedArray()                   As Variant
    Dim NoDupeRowArray()                As Variant
    Dim NoDupeSortedRowsArray()         As Variant
    Dim SalaryCalculationArray          As Variant, SalaryCalcShortenedArray()  As Variant
    Dim SalarySheetFullArray            As Variant, SalarySheetShortenedArray() As Variant
    Dim TempArray                       As Variant
    Dim UniqueWorksheetNamesArray       As Variant
    Dim varK                            As Variant
    Dim WorksheetArray                  As Variant
    Dim WorksheetColumnArray()          As Variant
    Dim names                           As Worksheet
    Dim wks                             As Worksheet
    Dim wksData                         As Worksheet
'
    Const MaxCombinationRows            As Long = 80000                                                                        ' <--- Set the MaxCombinationRows (100000) is probaly the max to be generated at a time
    Const MaxNoDupeRowArrayRows         As Long = 2100000                                                                       ' <--- Set the Max # rows we will possibly need
    Const MaxRowsPerSubArray            As Long = 80000                                                                        ' <--- Set the MaxRowsPerSubArray (100000) is probaly the max you would want
'
    ComboID_Display = True                                                                                                      ' <--- Set this to True or False to see/not see the ComboID column
    MaxSalaryAllowed = 60000                                                                                                    ' <--- set this value to what you want
'
'-------------------------------------------------------------------------------------------------------------------------------
'
    Call OptimizeCode_Begin
'
    Set wksData = ThisWorkbook.Sheets("Worksheet")
    Set names = Sheets("Salary")
'
'-------------------------------------------------------------------------------------------------------------------------------
'
' 1) Take all the names entered on the "Worksheet" (A2:Ix) sheet and check to see if all of those names also have a salary listed on the "Salary" sheet.
'    If any of the names from "Worksheet" are not on the "Salary" sheet, it ends Sub. If all the names are on the salary sheet and there are corresponding
'    salaries for each of those names, a pop up box will appear letting you know how many combinations to expect.
'
    'Check for salary worksheet
    For Each wks In ThisWorkbook.Worksheets
        If wks.Name = "Salary" Then bFoundSalary = True
    Next
'
    If Not bFoundSalary Then
        MsgBox "The workbook must contain a worksheet named 'Salary' with data starting in row 2 " & _
            "that consists of column A containing each name in the name/column layout worksheet " & _
            "and column B containng their salary."
'
        GoTo End_Sub
    End If
'
    'Make sure each name has a corresponding salary entry
    'Initialize the scripting dictionary
    Set oSD = CreateObject("Scripting.Dictionary")
    oSD.CompareMode = vbTextCompare
'
    'Inventory names on the main worksheet
    For Each cel In ActiveSheet.Range("A1").CurrentRegion.Offset(1, 0)
        cel.Value = Trim(cel.Value)
'
        If cel.Value <> vbNullString Then
            oSD.Item(cel.Value) = oSD.Item(cel.Value) + 1
        End If
    Next
'
    'Remove names on the Salary worksheet
    With Worksheets("Salary")
        For Each cel In .Range("A2:A" & .Cells(Rows.Count, 1).End(xlUp).Row)
            cel.Value = Trim(cel.Value)
'
            If oSD.Exists(cel.Value) Then
                oSD.Remove cel.Value
            End If
        Next
    End With
'
    'Any names not accounted for?
    If oSD.Count <> 0 Then
        varK = oSD.keys
'
        For lIndex = LBound(varK) To UBound(varK)
            sMissingSalary = sMissingSalary & ", " & varK(lIndex)
        Next
'
        sMissingSalary = Mid(sMissingSalary, 3)
'
        sOutput = "The following names on the main worksheet do not have a corresponding entry on the 'Salary' worksheet." & vbLf & vbLf & sMissingSalary
'
        MsgBox sOutput
        Debug.Print sOutput
'
        GoTo End_Sub
    End If
'
    Set oSD = CreateObject("Scripting.Dictionary")                                                          ' Erase contents of dictionary
    Set oSD = Nothing                                                                                       ' Delete the dictionary
'
    sErrorMsg = "Ensure a Worksheet is active with a header row starting in A1" & "and names under each header entry."
'
    If TypeName(ActiveSheet) <> "Worksheet" Then
        bShowError = True
    End If
'
    If bShowError Then
        MsgBox sErrorMsg, , "Problems Found in Data"
'
        GoTo End_Sub
    End If
'
    lLastColumn = Range("A1").CurrentRegion.Columns.Count
    lLastUsedColumn = ActiveSheet.UsedRange.Columns.Count
    ReDim aryNames(1 To 2, 1 To lLastColumn)                '1 holds the in-use entry row
'
    'How many combinations? (Order does not matter)
    lLastIteration = 1
'
    For lColumnIndex = 1 To lLastColumn
        aryNames(1, lColumnIndex) = 2
        aryNames(2, lColumnIndex) = Cells(Rows.Count, lColumnIndex).End(xlUp).Row
        lLastIteration = lLastIteration * (aryNames(2, lColumnIndex) - 1)
    Next
'
    Erase aryNames
'
    lFirstWriteColumn = lLastColumn + 2
    lLastWriteColumn = (2 * lLastColumn) + 1
'
    Select Case MsgBox("Process a " & lLastColumn & " column table with " & _
        lLastIteration & " possible combinations?" & vbLf & vbLf & _
        "WARNING: Columns right of the input range will be erased before continuing.", vbOKCancel + vbExclamation + _
        vbDefaultButton2, "Process table?")
'
        Case vbCancel
            GoTo End_Sub
    End Select
'
'-------------------------------------------------------------------------------------------------------------------------------
'
' 2) Clear all columns to the right of Column I on the "Worksheet" sheet. Copy headers from A1:I1 on the "Worksheet" sheet to K1:S1 on the "Worksheet" sheet.
'    Add header "ComboID" to T1 on the "Worksheet" sheet. Create the combinations & if there are no duplicate names in the same combination row then write the
'    combination of names & lIterationCount to NoDupeRowArray.
'
    dteStart = Now()
    StartTime = Now()
'
    Application.StatusBar = "Step 1 of 6 ... Calculating name combinations & saving combinations with no duplicate names in same combination ..."
    DoEvents
'
    'Clear all columns right of input range
    If lLastUsedColumn > lLastColumn Then
        Range(Cells(1, lLastColumn + 1), Cells(1, lLastUsedColumn)).EntireColumn.ClearContents
    End If
'
' Save Worksheet data into 2D 1 based WorksheetArray
    Set WorksheetNameRange = wksData.Range("A2:" & Split(Cells(1, lLastColumn).Address, "$")(1) & _
            wksData.Range("A1").CurrentRegion.Find("*", , xlFormulas, , xlByRows, xlPrevious).Row)
    WorksheetArray = WorksheetNameRange
'
    Cells(1, lLastWriteColumn + 1).Value = "ComboID"
'
    'Add Output Header
    Range(Cells(1, 1), Cells(1, lLastColumn)).Copy Destination:=Cells(1, lFirstWriteColumn)
'
' Load data from 'Worksheet', each column of data will be loaded into a separate array
    ReDim WorksheetColumnArray(1 To lLastColumn)                                                            ' Set the # of arrays in 'jagged' array WorksheetColumnArray
'
    For ArrayColumn = 1 To lLastColumn                                                                      ' Loop through the columns of 'Worksheet'
        lLastRow = Cells(Rows.Count, ArrayColumn).End(xlUp).Row                                             '   Get LastRow of the column
'
        ReDim TempArray(1 To lLastRow - 1, 1 To 1)                                                          '   Set the rows & columns of 2D 1 based TempArray
        WorksheetColumnArray(ArrayColumn) = TempArray                                                       '   Copy the empty 2D 1 based TempArray to WorksheetColumnArray()
'
        For ArrayRow = 1 To lLastRow - 1                                                                    '   Loop through the rows of data in the column
            WorksheetColumnArray(ArrayColumn)(ArrayRow, 1) = WorksheetArray(ArrayRow, ArrayColumn)          '       Save the data to WorksheetColumnArray()
        Next                                                                                                '   Loop back
    Next                                                                                                    ' Loop back
'
    'Start creating combinations
    lIterationCount = 0                                                                                     ' Reset lIterationCount
    lWriteRow = 0                                                                                           ' Reset lWriteRow
    CurrentRow = 0                                                                                          ' Reset WriteRow
'
    ReDim TempArray(1 To MaxCombinationRows, 1 To lLastColumn + 2)                                          ' Set up TempArray with rows = MaxCombinationRows & columns 2 more than data range
    ReDim NoDupeRowArray(1 To MaxNoDupeRowArrayRows, 1 To UBound(TempArray, 2) - 1)                         ' Set the # of rows/columns for NoDupeRowArray
'
    For ColumnA_Row = 1 To UBound(WorksheetColumnArray(1), 1)                                               ' Loop through rows of WorksheetColumnArray(1) ... Column A
        For ColumnB_Row = 1 To UBound(WorksheetColumnArray(2), 1)                                           '   Loop through rows of WorksheetColumnArray(2) ... Column B
            For ColumnC_Row = 1 To UBound(WorksheetColumnArray(3), 1)                                       '       Loop through rows of WorksheetColumnArray(3) ... Column C
                For ColumnD_Row = 1 To UBound(WorksheetColumnArray(4), 1)                                   '           Loop through rows of WorksheetColumnArray(4) ... Column D
                    For ColumnE_Row = 1 To UBound(WorksheetColumnArray(5), 1)                               '               Loop through rows of WorksheetColumnArray(5) ... Column E
                        For ColumnF_Row = 1 To UBound(WorksheetColumnArray(6), 1)                           '                   Loop through rows of WorksheetColumnArray(6) ... Column F
                            For ColumnG_Row = 1 To UBound(WorksheetColumnArray(7), 1)                       '                       Loop through rows of WorksheetColumnArray(7) ... Column G
                                For ColumnH_Row = 1 To UBound(WorksheetColumnArray(8), 1)                   '                           Loop through rows of WorksheetColumnArray(8) ... Column H
                                    For ColumnI_Row = 1 To UBound(WorksheetColumnArray(9), 1)               '                               Loop through rows of WorksheetColumnArray(9) ... Column I
                                        lIterationCount = lIterationCount + 1                               '                                   Increment lIterationCount
'
' Point to the next blank row in the NoDupeRowArray
                                        lWriteRow = lWriteRow + 1                                           '                                   Increment lWriteRow for TempArray
'
' Save the combination & ComboID to TempArray
                                        TempArray(lWriteRow, 1) = WorksheetColumnArray(1)(ColumnA_Row, 1)   '                                   Save name from column A to TempArray
                                        TempArray(lWriteRow, 2) = WorksheetColumnArray(2)(ColumnB_Row, 1)   '                                   Save name from column B to TempArray
                                        TempArray(lWriteRow, 3) = WorksheetColumnArray(3)(ColumnC_Row, 1)   '                                   Save name from column C to TempArray
                                        TempArray(lWriteRow, 4) = WorksheetColumnArray(4)(ColumnD_Row, 1)   '                                   Save name from column D to TempArray
                                        TempArray(lWriteRow, 5) = WorksheetColumnArray(5)(ColumnE_Row, 1)   '                                   Save name from column E to TempArray
                                        TempArray(lWriteRow, 6) = WorksheetColumnArray(6)(ColumnF_Row, 1)   '                                   Save name from column F to TempArray
                                        TempArray(lWriteRow, 7) = WorksheetColumnArray(7)(ColumnG_Row, 1)   '                                   Save name from column G to TempArray
                                        TempArray(lWriteRow, 8) = WorksheetColumnArray(8)(ColumnH_Row, 1)   '                                   Save name from column H to TempArray
                                        TempArray(lWriteRow, 9) = WorksheetColumnArray(9)(ColumnI_Row, 1)   '                                   Save name from column I to TempArray
'
                                        TempArray(lWriteRow, lLastColumn + 1) = lIterationCount             '                                   Save lIterationCount to TempArray
'
                                        If lWriteRow = MaxCombinationRows Then                              '                                   If we have written MaxCombinationRows to TempArray then ...
                                            ActiveSheet.Cells(2, lFirstWriteColumn).Resize(UBound(TempArray, _
                                                    1), UBound(TempArray, 2)) = TempArray                   '                                       Write the TempArray to the sheet
'
                                            lLastRow = Cells(Rows.Count, lFirstWriteColumn).End(xlUp).Row   '                                       Get lLastRow
                                            lLastUsedColumn = Rows(1).Find("*", , xlFormulas, , _
                                                    xlByColumns, xlPrevious).Column                         '                                       Get LastUsedColumn in row 1
' Add formula to each row
                                            Set rngFormulaRange = Range(Cells(2, lLastUsedColumn + 1), _
                                                    Cells(lLastRow, lLastUsedColumn + 1))                   '                                       Set the Range to place formulas in
'
                                            With rngFormulaRange
                                                .Formula = "=MODE.MULT(MATCH($" & Split(Cells(1, _
                                                        lFirstWriteColumn).Address, "$")(1) & "2:$" & _
                                                        Split(Cells(1, lLastUsedColumn).Address, "$")(1) & "2,$" & _
                                                        Split(Cells(1, lFirstWriteColumn).Address, "$")(1) & "2:$" & _
                                                        Split(Cells(1, lLastUsedColumn).Address, "$")(1) & _
                                                        "2,0))"                                             '                                               Formula to check for duplicates in same row
                                                Application.Calculate                                       '
                                                .Value = .Value                                             '
                                            End With
'
' Load the data with formula results back into TempArray
                                            TempArray = ActiveSheet.Cells(2, lFirstWriteColumn).Resize( _
                                                    UBound(TempArray, 1), UBound(TempArray, 2))             '
'
                                            For ArrayRow = 1 To UBound(TempArray, 1)                        '                                       Loop through rows of TempArray
                                                If Application.WorksheetFunction.IsNA(TempArray(ArrayRow, _
                                                        UBound(TempArray, 2))) Then                         '                                           If formula resulted in '#N/A' then ...
                                                    CurrentRow = CurrentRow + 1                             '                                               Increment CurrentRow, this is the
'                                                                                                           '                                                       row of the NoDupeRowArray
'
                                                    For ArrayColumn = 1 To UBound(TempArray, 2) - 1         '                                               Loop through columns of
'                                                                                                           '                                                       TempArray, except last column
                                                        NoDupeRowArray(CurrentRow, ArrayColumn) = _
                                                                TempArray(ArrayRow, ArrayColumn)            '                                                   Save values to NoDupeRowArray
                                                    Next                                                    '                                               Loop back
                                                End If
                                            Next                                                            '                                       Loop back
'
                                            lWriteRow = 0                                                   '                                       Reset lWriteRow for TempArray
'
                                            ActiveSheet.Cells(2, lFirstWriteColumn).Resize(UBound(TempArray, 1), _
                                                    UBound(TempArray, 2)).ClearContents                     '                                       Clear the data range
'
                                            ReDim TempArray(1 To MaxCombinationRows, 1 To lLastColumn + 2)  '                                       Clear results from TempArray
                                        End If
                                    Next                                                                    '                               Loop back
                                Next                                                                        '                           Loop back
                            Next                                                                            '                       Loop back
                        Next                                                                                '                   Loop back
                    Next                                                                                    '               Loop back
                Next                                                                                        '           Loop back
            Next                                                                                            '       Loop back
        Next                                                                                                '   Loop back
    Next                                                                                                    ' Loop back
'
    Erase WorksheetColumnArray
'
    If TempArray(1, 1) <> vbNullString Then                                                                 ' If there are more cominations needing to be checked then ...
        ActiveSheet.Cells(2, lFirstWriteColumn).Resize(UBound(TempArray, 1), UBound(TempArray, 2)) = TempArray  '   Write the TempArray to the sheet
'
        lLastRow = Cells(Rows.Count, lFirstWriteColumn).End(xlUp).Row                                       '   Get lLastRow
        lLastUsedColumn = Rows(1).Find("*", , xlFormulas, , xlByColumns, xlPrevious).Column                 '   Get LastUsedColumn in the sheet
'
' Add formula to each row
        Set rngFormulaRange = Range(Cells(2, lLastUsedColumn + 1), _
                Cells(lLastRow, lLastUsedColumn + 1))                                                       '   Set the Range to place formulas
'
        With rngFormulaRange
            .Formula = "=MODE.MULT(MATCH($" & Split(Cells(1, lFirstWriteColumn).Address, "$")(1) & "2:$" & _
                    Split(Cells(1, lLastUsedColumn).Address, "$")(1) & "2,$" & _
                    Split(Cells(1, lFirstWriteColumn).Address, "$")(1) & "2:$" & _
                    Split(Cells(1, lLastUsedColumn).Address, "$")(1) & "2,0))"                              '       Formula to check for duplicates in same row
            Application.Calculate                                                                           '
            .Value = .Value                                                                                 '
        End With
'
    Set rngFormulaRange = Nothing
'
' Load the data with formula results back into TempArray
        TempArray = ActiveSheet.Cells(2, lFirstWriteColumn).Resize(UBound(TempArray, 1), UBound(TempArray, 2))  '
'
        For ArrayRow = 1 To UBound(TempArray, 1)                                                            '   Loop through rows of TempArray
            If Application.WorksheetFunction.IsNA(TempArray(ArrayRow, UBound(TempArray, 2))) Then           '       If formula resulted in '#N/A' ( No duplicates in row) then ...
                CurrentRow = CurrentRow + 1                                                                 '           Increment CurrentRow, this is the row of the NoDupeRowArray
'
                For ArrayColumn = 1 To UBound(TempArray, 2) - 1                                             '           Loop through columns of TempArray, except last column
                    NoDupeRowArray(CurrentRow, ArrayColumn) = TempArray(ArrayRow, ArrayColumn)              '               Save values to NoDupeRowArray
                Next                                                                                        '           Loop back
            End If
        Next                                                                                                '   Loop back
'
        ActiveSheet.Cells(2, lFirstWriteColumn).Resize(UBound(TempArray, 1), UBound(TempArray, 2)).ClearContents    '   Clear the data range
    End If
'
    Erase TempArray                                                                                         '
'
    NoDupeRowArray = ReDimPreserve(NoDupeRowArray, CurrentRow, UBound(NoDupeRowArray, 2))                   ' Resize NoDupeRowArray to correct the actual rows used in the array
'
    Debug.Print "Create all combinations & remove rows with duplicate entries in the same row completed in:" & _
            Space(4) & Format(Now() - StartTime, "hh:mm:ss") & ", leaving " & UBound(NoDupeRowArray, 1) & _
            " combination rows."                                                                            ' Display elapsed time for this process to the 'Immediate' window (CTRL+G) in VBE
'
' At this point, NoDupeRowArray(1 thru 9) = names in original order, 10 = ComboID
'
'-------------------------------------------------------------------------------------------------------------------------------
'
' 3) Create a 'jagged array', which is just an array of arrays, of the remaining combinations. This us what allows us to handle
'       larger amounts of combinations. Instead of trying to write them all to the sheet for sorting, we will use the jagged array
'       to write amounts of combinations to the sheet that doesn't exceed the maximum amount of rows that Excel allows. We then
'       sort those rows & save the result back to the jagged array subArray, clear the sheet, write the next subArray to the sheet, sort the data,
'       save it back to the jagged array, etc.
'
    StartTime = Now()
'
    Application.StatusBar = "Step 2 of 6 ... Sorting remaining combination rows alphabetically by row ..."
    DoEvents
'
'    If UBound(NoDupeRowArray, 1) > Rows.Count Then                                                          ' If there are > total rows allowed on a sheet remaining then ...
        SubArrays = Int((UBound(NoDupeRowArray, 1) - 1) / MaxRowsPerSubArray) + 1                           '   Determine number of SubArrays needed
'
        ReDim JaggedArray(1 To SubArrays)                                                                   '   Set the # of SubArrays in JaggedArray
'
        CurrentRow = 0                                                                                      '   Reset CurrentRow
'
' Create array(s) of combinations
        For SubArrayNumber = 1 To SubArrays                                                                 '   Loop through SubArrays
            ReDim arrOut(1 To MaxRowsPerSubArray, 1 To UBound(NoDupeRowArray, 2))                           '       Reset the arrOut
'
            For SubArrayRow = 1 To MaxRowsPerSubArray                                                       '       Loop through rows of arrOut
                CurrentRow = CurrentRow + 1                                                                 '           Increment CurrentRow, this is the row of the NoDupeRowArray
'
                If CurrentRow > UBound(NoDupeRowArray, 1) Then Exit For                                     '           If all of the rows have been processed then exit this For loop
'
                For ArrayColumn = 1 To UBound(NoDupeRowArray, 2)                                            '           Loop through columns of NoDupeRowArray
                    arrOut(SubArrayRow, ArrayColumn) = NoDupeRowArray(CurrentRow, ArrayColumn)              '               Save column value into arrOut
                Next                                                                                        '           Loop back
            Next                                                                                            '       Loop back
'
            JaggedArray(SubArrayNumber) = arrOut                                                            '       Save the arrOut to the JaggedArray
'
            Erase arrOut
        Next                                                                                                '   Loop back
'
' At this point, all of the remaining combinations have been loaded into the JaggedArray subArrays
'
' Write each subArray to the sheet, sort each row & save results back into the subArray
        For SubArrayNumber = 1 To SubArrays                                                                 '   Loop through SubArrays
            ActiveSheet.Cells(2, lFirstWriteColumn).Resize(UBound(JaggedArray(SubArrayNumber), 1), _
                    UBound(JaggedArray(SubArrayNumber), 2)) = JaggedArray(SubArrayNumber)                   '       Write the subArray to the sheet for sorting
'
            ActiveSheet.Sort.SortFields.Clear                                                               '
'
' Sort each row
            lLastRow = Cells(Rows.Count, lFirstWriteColumn).End(xlUp).Row                                   '       Get lLastRow
'
            Set rngSortRange = Range(Cells(2, lFirstWriteColumn), Cells(lLastRow, lLastWriteColumn + 1))    '       Set the Range to be sorted
'
            For Each SortRowRange In rngSortRange.Rows                                                      '       Loop through each row of the range to be sorted
                SortRowRange.Sort Key1:=SortRowRange.Cells(1, 1), Order1:=xlAscending, _
                        Header:=xlNo, Orientation:=xlSortRows                                               '           Sort each row alphabetically
            Next                                                                                            '       Loop back
'
            Set rngSortRange = Nothing
            Set SortRowRange = Nothing
'
' Load the sorted data back into the subArray
            JaggedArray(SubArrayNumber) = ActiveSheet.Cells(2, lFirstWriteColumn).Resize(UBound( _
                    JaggedArray(SubArrayNumber), 1), UBound(JaggedArray(SubArrayNumber), 2))                '
'
            ActiveSheet.Cells(2, lFirstWriteColumn).Resize(UBound(JaggedArray(SubArrayNumber), 1), _
                 UBound(JaggedArray(SubArrayNumber), 2)).ClearContents                                      '       Clear the sort range
        Next                                                                                                '   Loop back
'
' At this point, the subArrays contain (ComboID) in column 1 and the sorted names in columns 2 thru 10 due to the sorting ;)
'
'    Else                                                                                                    ' Else ...
'        ActiveSheet.Cells(2, lFirstWriteColumn).Resize(UBound(NoDupeRowArray, 1), _
                UBound(NoDupeRowArray, 2)) = NoDupeRowArray                                                 '   Write NoDupeRowArray to the sheet for sorting
'
'        ActiveSheet.Sort.SortFields.Clear                                                                   '
'
' Sort each row
'        lLastRow = Cells(Rows.Count, lFirstWriteColumn).End(xlUp).Row                                       '   Get lLastRow
'
'        Set rngSortRange = Range(Cells(2, lFirstWriteColumn), Cells(lLastRow, lLastWriteColumn + 1))        '   Set the Range to be sorted
'
'        For Each SortRowRange In rngSortRange.Rows                                                          '   Loop through each row of the range to be sorted
'            SortRowRange.Sort Key1:=SortRowRange.Cells(1, 1), Order1:=xlAscending, _
                    Header:=xlNo, Orientation:=xlSortRows                                                   '       Sort each row alphabetically
'        Next                                                                                                '   Loop back
'
' At this point, the sheet contains (ComboID) in column 1 and the sorted names in columns 2 thru 10 due to the sorting ;)
'    End If
'
    Debug.Print "Sort remaining combination rows alphabetically by row completed " & _
            "in:" & Space(27) & Format(Now() - StartTime, "hh:mm:ss")                                       ' Display elapsed time for this process to the 'Immediate' window (CTRL+G) in VBE
'
'-------------------------------------------------------------------------------------------------------------------------------
'
' 4) Copy unique sorted rows from the subArrays to NoDupeSortedRowsArray
'
    StartTime = Now()
'
    Application.StatusBar = "Step 3 of 6 ... Removing duplicate sorted rows ..."
    DoEvents
'
    ReDim NoDupeSortedRowsArray(1 To UBound(NoDupeRowArray, 1), 1 To UBound(NoDupeRowArray, 2))             '
'
'    If UBound(NoDupeRowArray, 1) > Rows.Count Then                                                          ' If there are > total rows allowed on a sheet remaining then ...
'
' Join all of the sorted subArray unique rows back into 1 large array
'
        'Initialize the scripting dictionary
        Set oSD = CreateObject("Scripting.Dictionary")
        oSD.CompareMode = vbTextCompare
'
        CurrentRow = 0                                                                                      '   Reset CurrentRow
'
        For SubArrayNumber = 1 To SubArrays                                                                 '   Loop through the SubArrays
            For SubArrayRow = 1 To UBound(JaggedArray(SubArrayNumber), 1)                                   '       Loop through rows of each subArray in the JaggedArray
                oSD_KeyString = ""                                                                          '           Erase 'oSD_KeyString'
                Delimiter = ""                                                                              '           Erase 'Delimiter' of NoDupeSortedRowsArray
'
                For SubArrayColumn = 2 To UBound(JaggedArray(SubArrayNumber), 2)                            '           Loop through columns, except ComboID (first) column, of
'                                                                                                           '                   JaggedArray(SubArrayNumber)
                    oSD_KeyString = oSD_KeyString & Delimiter & _
                            JaggedArray(SubArrayNumber)(SubArrayRow, SubArrayColumn)                        '               Save data from JaggedArray(SubArrayNumber) row, separated
'                                                                                                           '                       by Delimiter, into oSD_KeyString
                    Delimiter = Chr(2)
                Next                                                                                        '           Loop back
'
                If Not oSD.Exists(oSD_KeyString) Then                                                       '           If this is a unique sorted name row then ...
                    oSD.Add oSD_KeyString, ""                                                               '               Add it to the dictionary
'
                    CurrentRow = CurrentRow + 1                                                             '               Increment CurrentRow
'
                    For ArrayColumn = 2 To UBound(JaggedArray(SubArrayNumber), 2)                           '               Loop through columns of JaggedArray(SubArrayNumber)
                        NoDupeSortedRowsArray(CurrentRow, ArrayColumn - 1) = _
                                JaggedArray(SubArrayNumber)(SubArrayRow, ArrayColumn)                       '                   Save values to NoDupeRowArray
                    Next                                                                                    '               Loop back
'
                    NoDupeSortedRowsArray(CurrentRow, UBound(JaggedArray(SubArrayNumber), 2)) = _
                            JaggedArray(SubArrayNumber)(SubArrayRow, 1)                                     '               Save ComboID to NoDupeSortedRowsArray
                End If
            Next                                                                                            '       Loop back
'
            Erase JaggedArray(SubArrayNumber)
        Next                                                                                                '   Loop back
'
        Erase JaggedArray
'
        Set oSD = CreateObject("Scripting.Dictionary")                                                      '   Erase contents of dictionary
        Set oSD = Nothing                                                                                   '   Delete the dictionary
'
        NoDupeSortedRowsArray = ReDimPreserve(NoDupeSortedRowsArray, _
                CurrentRow, UBound(NoDupeSortedRowsArray, 2))                                               '   Resize NoDupeSortedRowsArray to correct the actual rows used in the array
'
        Debug.Print "Removal of duplicate sorted rows completed in:" & Space(48) & _
                Format(Now() - StartTime, "hh:mm:ss") & ", leaving " & UBound(NoDupeSortedRowsArray, 1) & _
                " combination rows."                                                                        '   Display elapsed time for this process to the 'Immediate' window (CTRL+G) in VBE
'
' At this point, the unique sorted rows have been written to NoDupeSortedRowsArray &
'   NoDupeSortedRowsArray(1 thru 9) = names in sorted order, 10 = ComboID
'    Else                                                                                                    '
'        NoDupeSortedRowsArray = NoDupeRowArray                                                              '
'




'        ActiveSheet.Cells(2, lFirstWriteColumn).Resize(UBound(NoDupeRowArray, 1), _
                UBound(NoDupeRowArray, 2)) = NoDupeRowArray                                                 '   Write NoDupeRowArray to the sheet for sorting
'
'        Debug.Print "Removal of duplicate sorted rows, leaving " & UBound(NoDupeRowArray, 1) & _
                " rows, completed in " & Format(Now() - StartTime, "hh:mm:ss")                                  ' Display elapsed time for this process to the 'Immediate' window (CTRL+G) in VBE
'
'    End If
'
' At this point, the unique sorted rows have been written to NoDupeSortedRowsArray &
'   NoDupeSortedRowsArray(1 thru 9) = names in sorted order, 10 = ComboID
'
'-------------------------------------------------------------------------------------------------------
'
' 5) Now we need to match the ComboID in NoDupeSortedRowsArray to the ComboID in NoDupeRowArray so we can
'       put the names for that row back to the original order
'
    StartTime = Now()
'
    Application.StatusBar = "Step 4 of 6 ... Restoring original name order in the sorted rows ..."
    DoEvents
'
    CurrentRow = 1                                                                                          ' Initialize CurrentRow
'
    For ArrayRow = LBound(NoDupeRowArray, 1) To UBound(NoDupeRowArray, 1)                                   ' Loop through rows of NoDupeRowArray
        If CurrentRow > UBound(NoDupeSortedRowsArray, 1) Then Exit For                                      '   If we have processed all rows then exit this For loop
'
        If NoDupeSortedRowsArray(CurrentRow, UBound(NoDupeSortedRowsArray, 2)) = _
                NoDupeRowArray(ArrayRow, UBound(NoDupeRowArray, 2)) Then                                    '   If we found matching ComboID's then ...
'
            For ArrayColumn = LBound(NoDupeRowArray, 2) To UBound(NoDupeRowArray, 2) - 1                    '       Loop through the columns of NoDupeRowArray except for the last column
                NoDupeSortedRowsArray(CurrentRow, ArrayColumn) = NoDupeRowArray(ArrayRow, ArrayColumn)      '           Save the name from the row/column to NoDupeSortedRowsArray
            Next                                                                                            '       Loop back
'
            CurrentRow = CurrentRow + 1                                                                     '       Increment CurrentRow
        End If
    Next                                                                                                    ' Loop back
'
    Erase NoDupeRowArray                                                                                    '
'
    Debug.Print "Restore Original order of names in the remaining combinations completed in:" & _
            Space(19) & Format(Now() - StartTime, "hh:mm:ss")                                               ' Display elapsed time for this process to the 'Immediate' window (CTRL+G) in VBE
'
' At this point, NoDupeSortedRowsArray(1 thru 9) = names in original order, 10 = ComboID
'
'-------------------------------------------------------------------------------------------------------
'
' 6) Copy data on sheet to next set of columns. Insert a column for the salary total of each row. Save the unique
'       names from the 'Worksheet' into UniqueWorksheetNamesArray. Save respective data from 'Salary' sheet into
'       SalarySheetShortenedArray. Replace copied names in column U:AC with the players respective
'       salary data in SalarySheetShortenedArray. Sum the salaries from each of those rows & save results into
'       the added Salary column.
'
    StartTime = Now()
'
    Application.StatusBar = "Step 5 of 6 ... Removing all combination rows with salaries > " & MaxSalaryAllowed & " ..."
    DoEvents
'
    With Worksheets("Salary") '''' SALARY
        lLastSalaryRow = .Cells(.Rows.Count, 1).End(xlUp).Row                                           '
    End With
'
    With CreateObject("scripting.dictionary")
        .CompareMode = vbTextCompare                                                                    '
'
        For Each cel In WorksheetNameRange                                                              '       Loop through each cell in the WorksheetNameRange
            If cel <> "" Then                                                                           '           If the cell is not blank then ...
                If Not .Exists(cel.Value) Then                                                          '               If the value has not already been saved then ...
                    .Add cel.Value, cel.Value                                                           '                   Save the value
                End If
            End If
'
            UniqueWorksheetNamesArray = Application.Transpose(Array(.keys))                             '           Transpose results to 2D 1 based UniqueWorksheetNamesArray
        Next                                                                                            '       Loop back
    End With
'
    Set WorksheetNameRange = Nothing
    Set cel = Nothing
'
    SalarySheetFullArray = names.Range("A2:" & Split(Cells(names.Cells.Find("*", , _
            xlFormulas, , xlByColumns, xlPrevious).Column).Address, "$")(1) & lLastSalaryRow)           '   Save all of the data from the 'Salary' aheet into 2D 1 based SalarySheetFullArray
'
    ReDim SalarySheetShortenedArray(1 To UBound(SalarySheetFullArray, 1), _
            1 To UBound(SalarySheetFullArray, 2))                                                       '   Set 2D 1 based SalarySheetShortenedArray to the same size as SalarySheetFullArray
'
    CurrentRow = 0                                                                                      '   Initialize CurrentRow
'
    For UniqueArrayRow = 1 To UBound(UniqueWorksheetNamesArray, 1)                                      '   Loop through the rows of UniqueWorksheetNamesArray
        For ArrayRow = 1 To UBound(SalarySheetFullArray, 1)                                             '       Loop through the rows of SalarySheetFullArray
            If UniqueWorksheetNamesArray(UniqueArrayRow, 1) = SalarySheetFullArray(ArrayRow, 1) Then    '           If the name from UniqueWorksheetNamesArray is found in
'                                                                                                           '                   SalarySheetFullArray then ...
                CurrentRow = CurrentRow + 1                                                             '               Increment CurrentRow
'
                For lColumnIndex = 1 To UBound(SalarySheetFullArray, 2)                                 '               Loop through the columns of SalarySheetFullArray
                    SalarySheetShortenedArray(CurrentRow, lColumnIndex) = _
                            SalarySheetFullArray(ArrayRow, lColumnIndex)                                '                   Save the values to SalarySheetShortenedArray
                Next                                                                                    '               Loop back
            End If
        Next                                                                                            '       Loop back
    Next                                                                                                '   Loop back
'
    Erase SalarySheetFullArray
'
    SalarySheetShortenedArray = ReDimPreserve(SalarySheetShortenedArray, CurrentRow, _
            UBound(SalarySheetShortenedArray, 2))                                                       '   Resize SalarySheetShortenedArray to correct the actual rows used in the array
'
'-----------------
'
    SubArrays = Int((UBound(NoDupeSortedRowsArray, 1) - 1) / MaxRowsPerSubArray) + 1                    '   Determine number of SubArrays needed
'
    ReDim JaggedArray(1 To SubArrays)                                                                   '   Set the # of SubArrays in JaggedArray
'
    CurrentRow = 0                                                                                      '   Reset CurrentRow
'
' Create array(s) of combinations
    For SubArrayNumber = 1 To SubArrays                                                                 '   Loop through SubArrays
        ReDim arrOut(1 To MaxRowsPerSubArray, 1 To UBound(NoDupeSortedRowsArray, 2))                    '       Reset the arrOut
'
        For SubArrayRow = 1 To MaxRowsPerSubArray                                                       '       Loop through rows of arrOut
            CurrentRow = CurrentRow + 1                                                                 '           Increment CurrentRow, this is the row of the NoDupeRowArray
'
            If CurrentRow > UBound(NoDupeSortedRowsArray, 1) Then Exit For                              '           If all of the rows have been processed then exit this For loop
'
            For ArrayColumn = 1 To UBound(NoDupeSortedRowsArray, 2)                                     '           Loop through columns of NoDupeRowArray
                arrOut(SubArrayRow, ArrayColumn) = NoDupeSortedRowsArray(CurrentRow, ArrayColumn)       '               Save column value into arrOut
            Next                                                                                        '           Loop back
        Next                                                                                            '       Loop back
'
        JaggedArray(SubArrayNumber) = arrOut                                                            '       Save the arrOut to the JaggedArray
'
        Erase arrOut
    Next                                                                                                '   Loop back
'
' At this point, all of the remaining combinations have been loaded into the JaggedArray subArrays
'
'-----------------
'
' Write each subArray to the sheet, do salary calculations & save results back into the subArray
'
    ReDim SalaryCalcShortenedArray(1 To UBound(NoDupeSortedRowsArray, 1), _
            1 To UBound(NoDupeSortedRowsArray, 2) + 1)                                                  '   Set the # of rows/columns for SalaryCalcShortenedArray
'
    CurrentRow = 0                                                                                      '   Initialize CurrentRow
'
    For SubArrayNumber = 1 To SubArrays                                                                 '   Loop through SubArrays
        ActiveSheet.Cells(2, lFirstWriteColumn).Resize(UBound(JaggedArray(SubArrayNumber), 1), _
                UBound(JaggedArray(SubArrayNumber), 2)) = JaggedArray(SubArrayNumber)                   '       Write the subArray to the sheet
'
        lLastRow = Cells(Rows.Count, lFirstWriteColumn).End(xlUp).Row                                   '
'
        Columns(lLastUsedColumn).Insert                                                                 '       Insert column 20 ... U for the 'Salary'
'
' Add Sum Column
        Cells(1, lLastUsedColumn).Value = ChrW(931) & " Salary"                                         '       20 ... T
'
        Set rngReplace = Range(Cells(2, lFirstWriteColumn), Cells(lLastRow, lLastWriteColumn))          '
'
        For ArrayRow = 1 To UBound(SalarySheetShortenedArray, 1)                                        '   Loop through rows of SalarySheetShortenedArray
            rngReplace.Replace What:=SalarySheetShortenedArray(ArrayRow, 1), _
                    Replacement:=SalarySheetShortenedArray(ArrayRow, 2), LookAt:=xlWhole, _
                    SearchOrder:=xlByRows, MatchCase:=False, SearchFormat:=False, ReplaceFormat:=False  '
        Next                                                                                            '   Loop back
'
        Set rngReplace = Nothing
'
        With Range(Cells(2, lLastUsedColumn), Cells(lLastRow, lLastUsedColumn))
            .FormulaR1C1 = "=SUM(RC" & lFirstWriteColumn & ":RC" & lLastWriteColumn & ")"               '
            Application.Calculate                                                                       '
            .Value = .Value                                                                             '
        End With
'
'-------------------------------------------------------------------------------------------------------------------------------
'
' 7) Save the 'Salary' range of data into SalaryCalculationArray. Save allowable salary rows into SalaryCalcShortenedArray.
'       Match the ComboIDs for each row saved to the ComboIDs in NoDupeSortedRowsArray so we can replace the
'       respective names to the salaries.
'
        SalaryCalculationArray = Range(Cells(2, lFirstWriteColumn), Cells(lLastRow, lLastUsedColumn + 1))   '
'
        For ArrayRow = LBound(SalaryCalculationArray, 1) To UBound(SalaryCalculationArray, 1)           '   Loop through rows of SalaryCalculationArray
            If SalaryCalculationArray(ArrayRow, UBound(SalaryCalculationArray, 2) - 1) _
                    <= MaxSalaryAllowed Then                                                            '       If we have an allowable salary then ...
                CurrentRow = CurrentRow + 1                                                             '           Increment CurrentRow
'
                For ArrayColumn = LBound(SalaryCalculationArray, 2) To UBound(SalaryCalculationArray, 2)    '           Loop through the columns of SalaryCalculationArray
                    SalaryCalcShortenedArray(CurrentRow, ArrayColumn) = _
                            SalaryCalculationArray(ArrayRow, ArrayColumn)                               '               Save the data from the row to SalaryCalcShortenedArray
                Next                                                                                    '           Loop back
            End If
        Next                                                                                            '   Loop back
'
        Erase SalaryCalculationArray
'
        ActiveSheet.Cells(2, lFirstWriteColumn).Resize(UBound(JaggedArray(SubArrayNumber), 1), _
                UBound(JaggedArray(SubArrayNumber), 2) + 1).ClearContents                               '   Clear the calculation range
'
        Columns(lLastUsedColumn).EntireColumn.Delete                                                    '
'
        Erase JaggedArray(SubArrayNumber)
    Next                                                                                                ' Loop back
'
    Erase JaggedArray
'
    SalaryCalcShortenedArray = ReDimPreserve(SalaryCalcShortenedArray, CurrentRow, _
            UBound(SalaryCalcShortenedArray, 2))                                                        '
'
' Replace the individual Salary amounts with the original individual names by matching up the ComboIDs
    CurrentRow = 1                                                                                      ' Initialize CurrentRow
'
    For ArrayRow = LBound(NoDupeSortedRowsArray, 1) To UBound(NoDupeSortedRowsArray, 1)                 ' Loop through rows of NoDupeSortedRowsArray
        If NoDupeSortedRowsArray(ArrayRow, UBound(NoDupeSortedRowsArray, 2)) = _
                SalaryCalcShortenedArray(CurrentRow, UBound(SalaryCalcShortenedArray, 2)) Then          '   If we found matching ComboID's then ...
            For ArrayColumn = LBound(NoDupeSortedRowsArray, 2) To UBound(NoDupeSortedRowsArray, 2) - 1  '       Loop through the columns of NoDupeSortedRowsArray except for the last column
                SalaryCalcShortenedArray(CurrentRow, ArrayColumn) = _
                        NoDupeSortedRowsArray(ArrayRow, ArrayColumn)                                    '           Save the name from the row/column to SalaryCalcShortenedArray
            Next                                                                                        '       Loop back
'
            CurrentRow = CurrentRow + 1                                                                 '       Increment CurrentRow
'
            If CurrentRow > UBound(SalaryCalcShortenedArray, 1) Then Exit For                           '
        End If
    Next                                                                                                ' Loop back
'
'
' At this point, all criteria for deletion of combination rows have been completed
'
    Erase NoDupeSortedRowsArray
'
' Add Sum Column
    Columns(lLastUsedColumn).Insert                                                                     ' Insert column for the 'Salary'
'
    Cells(1, lLastUsedColumn).Value = ChrW(931) & " Salary"                                             ' 20 ... T
'
    If UBound(SalaryCalcShortenedArray, 1) > Rows.Count Then                                            ' If the remaining amount of combinations> 1048576 then ...
        ExcessCombinations = UBound(SalaryCalcShortenedArray, 1) - Rows.Count                           '   Calculate the remaining combinations that will not be printed
'
        SalaryCalcShortenedArray = ReDimPreserve(SalaryCalcShortenedArray, Rows.Count, _
            UBound(SalaryCalcShortenedArray, 2))                                                        '   Limit the displayed rows to the sheet allowable range, discard the rest of the combos
    End If
'
    Cells(2, lFirstWriteColumn).Resize(UBound(SalaryCalcShortenedArray, 1), _
            UBound(SalaryCalcShortenedArray, 2)) = SalaryCalcShortenedArray                             '   Display SalaryCalcShortenedArray to 'Worksheet'
'
' We need to swap the last 2 columns (Salary & ComboID)
    Columns(lLastUsedColumn).Insert                                                                     ' Insert a blank column
    Columns(lLastUsedColumn + 2).Cut Cells(1, lLastUsedColumn)                                          ' Cut/paste the last column into the inserted column
'
    Debug.Print "Remove all combinations with salaries > " & MaxSalaryAllowed & " completed in:" & _
            Space(35) & Format(Now() - StartTime, "hh:mm:ss") & ", leaving " & _
            UBound(SalaryCalcShortenedArray, 1) & " combination rows"                                   ' Display elapsed time for this process to the 'Immediate' window (CTRL+G) in VBE
'
    Erase SalaryCalcShortenedArray
'    Else
'    End If
'
'-------------------------------------------------------------------------------------------------------------------------------
'
' 8) A projection column is added to column AW. The projections from columns AD:AL are
'    calculated(summed) and entered into column AW. A "Stack" column is added to column AX and the most used team in the combinations are calculated using the
'    MODE function. A "Stack POS" column is added to column AY. The players position - who consisted of the most used team are added to column AY by pulling the
'    column headers associated to the corresponding player using the TEXTJOIN function. A "" Stack2" column is added to the AZ column and a "Stack2 POS" column
'    is added to the BA column - Both using the similar method as first stack column.
'
    StartTime = Now()
'
    Application.StatusBar = "Step 6 of 6 ...Wrapping up ..."
    DoEvents
'
    lLastRow = Cells(Rows.Count, lFirstWriteColumn).End(xlUp).Row                                       '
'
    lFirstHSortColumn = Rows(1).Find("*", , xlFormulas, , xlByColumns, xlPrevious).Column + 1
'
    If lLastRow > 1 Then                                                                                '
        Range(Cells(1, lFirstWriteColumn), Cells(lLastRow, lLastWriteColumn)).Copy _
                Destination:=Cells(1, lFirstHSortColumn)                                                '   Rows for PROJECTION
'
        lLastHSortColumn = Cells(1, Columns.Count).End(xlToLeft).Column                                 '   30 ... AD
'
        Range(Cells(1, lFirstWriteColumn), Cells(lLastRow, lLastWriteColumn)).Copy _
                Destination:=Cells(1, lLastHSortColumn + 1)                                             '   Rows for TEAM
'
        lFirstHTeamCol = lLastHSortColumn + 1                                                           '   31 ... AE
        lLastHTeamCol = Cells(1, Columns.Count).End(xlToLeft).Column                                    '   39 ... AM
'
        Set rngReplace2 = Range(Cells(2, lFirstHSortColumn), Cells(lLastRow, lLastHSortColumn))         '   22 ... V ... 30 ... AD
        Set rngReplace3 = Range(Cells(2, lFirstHTeamCol), Cells(lLastRow, lLastHTeamCol))               '   31 ... AE ... 39 ... AM
'
        For ArrayRow = 1 To UBound(SalarySheetShortenedArray, 1)                                        '   Loop through rows of SalarySheetShortenedArray
'
'''''''''''''''''''''''''''''''''''''PROJECTION
            rngReplace2.Replace What:=SalarySheetShortenedArray(ArrayRow, 1), _
                Replacement:=SalarySheetShortenedArray(ArrayRow, 3), LookAt:=xlWhole, _
                SearchOrder:=xlByRows, MatchCase:=False, SearchFormat:=False, ReplaceFormat:=False      '
'
'
         '''''''''''''''''''''''''''''''''''''TEAM
            rngReplace3.Replace What:=SalarySheetShortenedArray(ArrayRow, 1), _
                Replacement:=SalarySheetShortenedArray(ArrayRow, 4), LookAt:=xlWhole, _
                SearchOrder:=xlByRows, MatchCase:=False, SearchFormat:=False, ReplaceFormat:=False      '
        Next                                                                                            '   Loop back
'
        Set rngReplace2 = Nothing
        Set rngReplace3 = Nothing
'
' Add Projection Column
        Cells(1, lLastHTeamCol + 1).Value = ChrW(931) & " Projection"                                   '   40 ... AN
' Add Team Stack Column
        Cells(1, lLastHTeamCol + 2).Value = ChrW(931) & " Stack"                                        '   41 ... AO
' Add Team Stack Pos
        Cells(1, lLastHTeamCol + 3).Value = ChrW(931) & " Stack POS"                                    '   42 ... AP
' Add 2nd Team Stack Column
        Cells(1, lLastHTeamCol + 4).Value = ChrW(931) & " Stack2"                                       '   43 ... AQ
' Add 2nd Team Stack Pos
        Cells(1, lLastHTeamCol + 5).Value = ChrW(931) & " Stack2 POS"                                   '   44 ... AR
' Filter 0-1
        Cells(1, lLastHTeamCol + 6).Value = ChrW(931) & " Filter"                                       '   45 ... AS
' Player 1 Filter
        Cells(1, lLastHTeamCol + 7).Value = ChrW(931) & " Player1"                                      '   46 ... AT
' Player 2 Filter
        Cells(1, lLastHTeamCol + 8).Value = ChrW(931) & " Player2"                                      '   47 ... AU
'
        With Range(Cells(2, lLastHTeamCol + 1), Cells(lLastRow, lLastHTeamCol + 1))
            .FormulaR1C1 = "=SUM(RC" & lFirstHSortColumn & ":RC" & lLastHSortColumn & ")"               '       Projection formula
            Application.Calculate                                                                       '
            .Value = .Value                                                                             '
        End With
'
        With Range(Cells(2, lLastHTeamCol + 2), Cells(lLastRow, lLastHTeamCol + 2))
            .FormulaR1C1 = "=INDEX(RC" & lFirstHTeamCol & ":RC" & lLastHTeamCol & ",MODE(MATCH(RC" & _
                    lFirstHTeamCol & ":RC" & lLastHTeamCol & ",RC" & lFirstHTeamCol & ":RC" & _
                    lLastHTeamCol & ",0)))"                                                             '       Stack formula
            Application.Calculate                                                                       '
            .Value = .Value                                                                             '
        End With
'
        With Range(Cells(2, lLastHTeamCol + 3), Cells(lLastRow, lLastHTeamCol + 3))
            .Formula2R1C1 = "=TEXTJOIN("","",1,IF(RC[-11]:RC[-3]=RC[-1],R1C[-11]:R1C[-3],""""))"        '       Stack POS
            Application.Calculate                                                                       '
            .Value = .Value                                                                             '
        End With
'
        With Range(Cells(2, lLastHTeamCol + 4), Cells(lLastRow, lLastHTeamCol + 4))
            .Formula2R1C1 = "=IFERROR(INDEX(RC[-12]:RC[-4],MODE(IF((RC[-12]:RC[-4]<>"""")*" & _
                    "(RC[-12]:RC[-4]<>INDEX(RC[-12]:RC[-4],MODE(IF(RC[-12]:RC[-4]<>"""",MATCH(" & _
                    "RC[-12]:RC[-4],RC[-12]:RC[-4],0))))),MATCH(RC[-12]:RC[-4],RC[-12]:RC[-4],0)))),"""")"  '       Stack2 formula
            Application.Calculate                                                                       '
            .Value = .Value                                                                             '
        End With
'
        With Range(Cells(2, lLastHTeamCol + 5), Cells(lLastRow, lLastHTeamCol + 5))
            .Formula2R1C1 = "=TEXTJOIN("","",1,IF(RC[-13]:RC[-5]=RC[-1],R1C[-13]:R1C[-5],""""))"        '
            Application.Calculate                                                                       '
            .Value = .Value                                                                             '
        End With
'
'-------------------------------------------------------------------------------------------------------------------------------
'
' 9) "Filter" column added to column BB, "Player1" column added to column BC, "Player2" column added to column BD. Nothing is calculated in these
'    columns. Only Headers added. Currently not a used function for this project.
'
        With Range(Cells(2, lLastHTeamCol + 6), Cells(lLastRow, lLastHTeamCol + 6))                     '
        End With
'
        With Range(Cells(2, lLastHTeamCol + 7), Cells(lLastRow, lLastHTeamCol + 7))                     '
        End With
'
        With Range(Cells(2, lLastHTeamCol + 8), Cells(lLastRow, lLastHTeamCol + 8))                     '
        End With
    Else                                                                                                '
        MsgBox "No rows qualified for further testing."                                                 '
'
        GoTo End_Sub
    End If
'
'-------------------------------------------------------------------------------------------------------------------------------
'
' 10) Removes all helper columns - U:AU. "Salary" column becomes column U. "Projection" column becomes column V. "Stack" column becomes column W. "Stack POS"
'    column becomes column X. "Stack 2" column becomes column Y. "Stack 2 POS" column becomes column Z. Filter column becomes column AA. "Player1" Column
'    becomes column AB. "Player2" column becomes column AC.. A Dialogue Box then pops open and provides combination info: Possible combinations,
'    unique combinations, duplicates removed, and the time to process. Data is then autofitted to the used range and printed to the "Worksheet".
'    OptimizeCode_End is then called, which is just turning back on screen updating and whatnot.
'
' Remove Salary Columns
'
    Range(Columns(lFirstHSortColumn), Columns(lLastHTeamCol)).Delete                                    ' Delete columns V:AM ... 22 thru 39
'
    If ComboID_Display = False Then Columns(lLastWriteColumn + 1).Delete                                ' Delete ComboID column if user chose not to see it
'
    ActiveSheet.UsedRange.Columns.AutoFit                                                               '
'
    sOutput = lLastIteration & vbTab & " possible combinations" & vbLf & lLastRow - 1 & vbTab & _
            " unique name combinations" & vbLf & IIf(lLastRow < lLastRow, lLastRow - lLastRow & vbTab & _
            " duplicate rows removed." & vbLf, "") & lLastRow - 1 & vbTab & " printed." & vbLf & vbLf & ExcessCombinations & " combinations were not displayed due to sheet restraints" & _
            vbLf & vbLf & Format(Now() - dteStart, "hh:mm:ss") & " to process."                                       '
'
    Debug.Print "Wrapping up completed in:" & Space(69) & Format(Now() - StartTime, "hh:mm:ss")         ' Display elapsed time for this process to the 'Immediate' window (CTRL+G) in VBE
'
    Debug.Print vbLf & sOutput                                                                          '
    MsgBox sOutput, , "Output Report"                                                                   '
'
End_Sub:
    Call OptimizeCode_End
End Sub



Public Function ReDimPreserve(ArrayNameToResize, NewRowUbound, NewColumnUbound)
'
' Code inspired by Control Freak
'
' Preserve Original data & LBounds & Redim both dimensions for a 2D array
'
' example usage of the function:
' ArrayName = ReDimPreserve(ArrayName,NewRowSize,NewColumnSize)
' ie.
' InputArray = ReDimPreserve(InputArray,10,20)
'
    Dim NewColumn                   As Long, NewRow                      As Long
    Dim OldColumnLbound             As Long, OldRowLbound                As Long
    Dim OldColumnUbound             As Long, OldRowUbound                As Long
    Dim NewResizedArray()           As Variant
'
    ReDimPreserve = False
'
    If IsArray(ArrayNameToResize) Then                                                                      ' If the variable is an array then ...
           OldRowLbound = LBound(ArrayNameToResize, 1)                                                      '   Save the original row Lbound to OldRowLbound
        OldColumnLbound = LBound(ArrayNameToResize, 2)                                                      '   Save the original column Lbound to OldColumnLbound
'
        ReDim NewResizedArray(OldRowLbound To NewRowUbound, OldColumnLbound To NewColumnUbound)             '   Create a New 2D Array with same Lbounds as the original array
'
        OldRowUbound = UBound(ArrayNameToResize, 1)                                                         '   Save row Ubound of original array
        OldColumnUbound = UBound(ArrayNameToResize, 2)                                                      '   Save column .Ubound of original array
'
        For NewRow = OldRowLbound To NewRowUbound                                                           '   Loop through rows of original array
            For NewColumn = OldColumnLbound To NewColumnUbound                                              '       Loop through columns of original array
                If OldRowUbound >= NewRow And OldColumnUbound >= NewColumn Then                             '           If more data to copy then ...
                    NewResizedArray(NewRow, NewColumn) = ArrayNameToResize(NewRow, NewColumn)               '               Append rows/columns to NewResizedArray
                End If
            Next                                                                                            '       Loop back
        Next                                                                                                '   Loop back
'
        Erase ArrayNameToResize                                                                             '   Free up the memory the Original array was taking
'
        If IsArray(NewResizedArray) Then ReDimPreserve = NewResizedArray
    End If
End Function
```

That code does all the previous code changes discussed. It adds the last code, to eliminate the salary values > 60000, as well as preventing more rows than allowed to be printed to the sheet.

Let me know your results


----------



## cspengel (Dec 17, 2022)

johnnyL said:


> Ok here is the latest result:
> 
> ```
> Create all combinations & remove rows with duplicate entries in the same row completed in:    00:01:13, leaving 2021760 combination rows.
> ...


Awesome johnny, I'll run some tests in a bit and get back to you. Thanks again


----------



## cspengel (Dec 17, 2022)

Here is a Couple tests   Extremely happy with the results and couldn't ask for anything more!  The removal of salary before adding to sheet helps tremendously in getting more combinations. Thank you thank you johnnyL!


```
Create all combinations & remove rows with duplicate entries in the same row completed in:    00:02:06, leaving 3607200 combination rows.
Sort remaining combination rows alphabetically by row completed in:                           00:25:29
Removal of duplicate sorted rows completed in:                                                00:01:27, leaving 685801 combination rows.
Restore Original order of names in the remaining combinations completed in:                   00:00:05
Remove all combinations with salaries > 60000 completed in:                                   00:02:04, leaving 296760 combination rows
Wrapping up completed in:                                                                     00:01:51

5971968  possible combinations
296760   unique name combinations
296760   printed.

0 combinations were not displayed due to sheet restraints

00:33:02 to process.
```



```
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.
```


----------



## johnnyL (Dec 17, 2022)

Holy cow! That is way better than what you started with in the first post here.  

I have actually just started looking at the code again & I have some ideas of how to make it faster. 🤫


----------



## cspengel (Dec 17, 2022)

johnnyL said:


> Holy cow! That is way better than what you started with in the first post here.
> 
> I have actually just started looking at the code again & I have some ideas of how to make it faster. 🤫


Considering I was at nearly an hour before I started this whole process for a whole lot less combinations, an hour for 9 Million isn't bad at all! I won't complain if you have more ideas up your sleeve though


----------



## cspengel (Dec 18, 2022)

I just wanted to provide you on an update - Code works great - but I don't think the code that deals with removing combinations that don't fit on the sheet works. Not a big deal, but wanted to at least test that function so I ran enough to go over the limit. 

For this test I ran 9,525,600 combinations. It failed on step 5 (the removing of combinations less than 60,000. It received a "Error 400". After adding error handler, it is "Application-defined or object defined error."

I had it return how many rows were on the sheet at time of failure by using 
	
	
	
	
	
	



```
Debug.Print UBound(SalaryCalcShortenedArray, 1)
```
. It returned it was at the max rows for a sheet(1048576).
I also had it return how much was over the sheet limit by using 
	
	
	
	
	
	



```
Debug.Print ExcessCombinations
```
, which returned it was over the limit by 540499 combinations. 

Thanks again!


----------



## jdellasala (Dec 18, 2022)

cspengel said:


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


That's because VBA is the wrong tool to be handling tha4t much data, and it's what Power Query and the Data Model eat for breakfast! I have a sample Workbook that pulls in over 10 million rows of data, and produces a full Power Pivot report, and can be used in a Pivot Chart.
There are treat YouTube playlists on the subject *here* and *here*. Remember, when you pull the data in and do whatever transformations are needed, you load as Connection Only, AND check Add to the Data Model box. Assuming the data has dates, it's worth building a Calendar table which can be created automatically, and then link the Calendar Date to the Date field in the Data Table.


----------



## cspengel (Dec 18, 2022)

jdellasala said:


> That's because VBA is the wrong tool to be handling tha4t much data, and it's what Power Query and the Data Model eat for breakfast! I have a sample Workbook that pulls in over 10 million rows of data, and produces a full Power Pivot report, and can be used in a Pivot Chart.
> There are treat YouTube playlists on the subject *here* and *here*. Remember, when you pull the data in and do whatever transformations are needed, you load as Connection Only, AND check Add to the Data Model box. Assuming the data has dates, it's worth building a Calendar table which can be created automatically, and then link the Calendar Date to the Date field in the Data Table.


It is working well for what I need, I am just trying to make sure it is resizing to it's proper size. 

If I change 

```
SalaryCalcShortenedArray = ReDimPreserve(SalaryCalcShortenedArray, Rows.Count, _
            UBound(SalaryCalcShortenedArray, 2))
```

to this:


```
SalaryCalcShortenedArray = ReDimPreserve(SalaryCalcShortenedArray, Rows.Count - 1, _
            UBound(SalaryCalcShortenedArray, 2))
```

I don't get a subscript error and all the rows fit at exactly 1048576, It just isn't continuing to the next line of code to add the projection columns. Instead it skips to popup box johnnyL added that says "No rows qualified for further testing." I'm sure he will be able to provide more insight for me later. Thanks for your insight though.


----------



## johnnyL (Dec 18, 2022)

cspengel said:


> It is working well for what I need, I am just trying to make sure it is resizing to it's proper size.
> 
> If I change
> 
> ...



You are correct, I forgot about the header row.   

Rows.Count - 1 is what it should be, sorry about that.

I am wrapping up the idea that I had for the next version to speed up the code. I just have to clean up the code and add some timers to see which sections of code are requiring the most time to process.


----------



## cspengel (Nov 25, 2022)

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



```
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
```


----------



## cspengel (Dec 18, 2022)

johnnyL said:


> You are correct, I forgot about the header row.
> 
> Rows.Count - 1 is what it should be, sorry about that.
> 
> I am wrapping up the idea that I had for the next version to speed up the code. I just have to clean up the code and add some timers to see which sections of code are requiring the most time to process.


Thanks for the response johnny, look forward to seeing what you come up with.  

& the problem is once that Rows.Count is changed to Rows.Count - 1, the code does not add the projection column, projections, or filter columns and the msgbox pops up with the below msg. 


```
Else                                                                                                '
        MsgBox "No rows qualified for further testing."                                                 '
'
        GoTo End_Sub
```

Would this Rows.Count need to be changed to Rows.Count - 1 as well?


```
lLastRow = Cells(Rows.Count, lFirstWriteColumn).End(xlUp).Row
```


----------



## johnnyL (Dec 18, 2022)

cspengel said:


> Would this Rows.Count need to be changed to Rows.Count - 1 as well?
> 
> 
> ```
> ...



No, that is a different animal.


----------



## johnnyL (Dec 20, 2022)

An update while I clean up some code, the current code I am working on appears to be about 40% quicker than the results displayed in post #123


```
Create all combinations & remove rows with duplicate name entries in the same row & & remove all combinations with salaries > 60000 completed in:    00:07:39, leaving 531007 combination rows.
Restore Original order of names in the remaining combinations completed in:                                                                          00:00:03
Sort remaining combination rows alphabetically by row completed in:                                                                                  00:01:47
Removal of duplicate sorted rows completed in:                                                                                                       00:00:23, leaving 364253 combination rows.
Restore Original order of names in the remaining combinations completed in:                                                                          00:00:01
Wrapping up completed in:                                                                                                                            00:02:27

3144960  possible combinations
364253   unique name combinations
364253   printed.

0 combinations were not displayed due to sheet restraints

00:12:20 to process.
```


----------



## johnnyL (Dec 21, 2022)

Here is the 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 NameCombosV19()
    '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 ComboID_Column                  As Long, ComboID_Row                    As Long
    Dim CurrentRow                      As Long, NoDupeRow                      As Long, NoDupeRow2                     As Long
    Dim ExcessCombinations              As Long
    Dim lLastRow                        As Long
    Dim lColumnIndex                    As Long
    Dim lFirstHSortColumn               As Long, lFirstHSortColumn2             As Long
    Dim lFirstHTeamCol                  As Long, lLastHTeamCol                  As Long
    Dim lFirstWriteColumn               As Long, lLastWriteColumn               As Long
    Dim lIndex                          As Long
    Dim lIterationCount                 As Long, lLastIteration                 As Long
    Dim lLastColumn                     As Long
    Dim lLastHSortColumn                As Long, lLastHSortColumn2              As Long
    Dim lLastSalaryRow                  As Long
    Dim lLastUsedColumn                 As Long
    Dim lWriteRow                       As Long
    Dim MaxNoDupeRowArrayRows           As Long
    Dim MaxPasses                       As Long, PassNumber                     As Long
    Dim MaxSalaryAllowed                As Long
    Dim SubArrayNumber                  As Long
    Dim SubArrayColumn                  As Long, SubArrayRow                    As Long
    Dim SubArrays                       As Long
    Dim UniqueArrayRow                  As Long
    Dim oSD                             As Object
    Dim cel                             As Range
    Dim rngFormulaRange                 As Range
    Dim rngReplace                      As Range, rngReplace2                   As Range, rngReplace3                   As Range
    Dim rngSortRange                    As Range
    Dim SortRowRange                    As Range
    Dim WorksheetNameRange              As Range
    Dim Delimiter                       As String
    Dim oSD_KeyString                   As String
    Dim sErrorMsg                       As String
    Dim sMissingSalary                  As String
    Dim sOutput                         As String
    Dim arrOut()                        As Variant
    Dim aryDeDupe                       As Variant
    Dim aryNames                        As Variant
    Dim JaggedArray()                   As Variant
    Dim NamesAndComboIdArray            As Variant
    Dim NoDupeRowArray()                As Variant
    Dim NoDupeSortedRowsArray()         As Variant
    Dim PlayerSalaryArray()             As Variant
    Dim SalarySheetFullArray            As Variant, SalarySheetShortenedArray() As Variant
    Dim TempArray                       As Variant, TempArray2                  As Variant
    Dim UniqueWorksheetNamesArray       As Variant
    Dim varK                            As Variant
    Dim WorksheetArray                  As Variant
    Dim WorksheetColumnArray()          As Variant
    Dim names                           As Worksheet
    Dim wks                             As Worksheet
    Dim wksData                         As Worksheet
'
    Const MaxCombinationRows            As Long = 200000                                                                        ' <--- Set the MaxCombinationRows (200000) is probaly the max to be generated at a time
    Const MaxRowsPerSubArray            As Long = 200000                                                                        ' <--- 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
        varK = oSD.keys
'
        For lIndex = LBound(varK) To UBound(varK)
            sMissingSalary = sMissingSalary & ", " & varK(lIndex)
        Next
'
        sMissingSalary = Mid(sMissingSalary, 3)
'
        sOutput = "The following names on the main worksheet do not have a corresponding entry on the 'Salary' worksheet." & vbLf & vbLf & sMissingSalary
'
        MsgBox sOutput
        Debug.Print sOutput
'
        GoTo End_Sub
    End If
'
    Set oSD = CreateObject("Scripting.Dictionary")                                                          ' Erase contents of dictionary
    Set oSD = Nothing                                                                                       ' Delete the dictionary
'
    sErrorMsg = "Ensure a Worksheet is active with a header row starting in A1" & "and names under each header entry."
'
    If TypeName(ActiveSheet) <> "Worksheet" Then
        bShowError = True
    End If
'
    If bShowError Then
        MsgBox sErrorMsg, , "Problems Found in Data"
'
        GoTo End_Sub
    End If
'
    lLastColumn = Range("A1").CurrentRegion.Columns.Count
    lLastUsedColumn = ActiveSheet.UsedRange.Columns.Count
    ReDim aryNames(1 To 2, 1 To lLastColumn)                '1 holds the in-use entry row
'
    'How many combinations? (Order does not matter)
    lLastIteration = 1
'
    For lColumnIndex = 1 To lLastColumn
        aryNames(1, lColumnIndex) = 2
        aryNames(2, lColumnIndex) = Cells(Rows.Count, lColumnIndex).End(xlUp).Row
        lLastIteration = lLastIteration * (aryNames(2, lColumnIndex) - 1)
    Next
'
    MaxNoDupeRowArrayRows = lLastIteration
'
    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 WorksheetArray
    Set WorksheetNameRange = wksData.Range("A2:" & Split(Cells(1, lLastColumn).Address, "$")(1) & _
            wksData.Range("A1").CurrentRegion.Find("*", , xlFormulas, , xlByRows, xlPrevious).Row)
    WorksheetArray = WorksheetNameRange
'
    Cells(1, lLastWriteColumn + 1).Value = "ComboID"
'
    'Add Output Header
    Range(Cells(1, 1), Cells(1, lLastColumn)).Copy Destination:=Cells(1, lFirstWriteColumn)
'
' Load data from 'Worksheet', each column of data will be loaded into a separate array
    ReDim WorksheetColumnArray(1 To lLastColumn)                                                            ' Set the # of arrays in 'jagged' array WorksheetColumnArray
'
    For ArrayColumn = 1 To lLastColumn                                                                      ' Loop through the columns of 'Worksheet'
        lLastRow = Cells(Rows.Count, ArrayColumn).End(xlUp).Row                                             '   Get LastRow of the column
'
        ReDim TempArray(1 To lLastRow - 1, 1 To 1)                                                          '   Set the rows & columns of 2D 1 based TempArray
        WorksheetColumnArray(ArrayColumn) = TempArray                                                       '   Copy the empty 2D 1 based TempArray to WorksheetColumnArray()
'
        For ArrayRow = 1 To lLastRow - 1                                                                    '   Loop through the rows of data in the column
            WorksheetColumnArray(ArrayColumn)(ArrayRow, 1) = WorksheetArray(ArrayRow, ArrayColumn)          '       Save the data to WorksheetColumnArray()
        Next                                                                                                '   Loop back
    Next                                                                                                    ' Loop back
'
'-------------------------------------------------------------------------------------------------------
'
' 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 same size as SalarySheetFullArray
'
    CurrentRow = 0                                                                                          '   Initialize CurrentRow
'
    For UniqueArrayRow = 1 To UBound(UniqueWorksheetNamesArray, 1)                                          '   Loop through the rows of UniqueWorksheetNamesArray
        For ArrayRow = 1 To UBound(SalarySheetFullArray, 1)                                                 '       Loop through the rows of SalarySheetFullArray
            If UniqueWorksheetNamesArray(UniqueArrayRow, 1) = SalarySheetFullArray(ArrayRow, 1) Then        '           If the name from UniqueWorksheetNamesArray is found in
'                                                                                                           '                   SalarySheetFullArray then ...
                CurrentRow = CurrentRow + 1                                                                 '               Increment CurrentRow
'
                For lColumnIndex = 1 To UBound(SalarySheetFullArray, 2)                                     '               Loop through the columns of SalarySheetFullArray
                    SalarySheetShortenedArray(CurrentRow, lColumnIndex) = _
                            SalarySheetFullArray(ArrayRow, lColumnIndex)                                    '                   Save the values to SalarySheetShortenedArray
                Next                                                                                        '               Loop back
            End If
        Next                                                                                                '       Loop back
    Next                                                                                                    '   Loop back
'
    Erase SalarySheetFullArray
'
    SalarySheetShortenedArray = ReDimPreserve(SalarySheetShortenedArray, CurrentRow, _
            UBound(SalarySheetShortenedArray, 2))                                                           '   Resize SalarySheetShortenedArray to correct the actual rows used in the array
'
'-------------------------------------------------------------------------------------------------------
'
' 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 + 3)                                          ' Set up TempArray with rows = MaxCombinationRows & columns 3 more than data range
    ReDim TempArray2(1 To MaxCombinationRows, 1 To lLastColumn + 3)                                          ' 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 save the Names and ComboIDs to NamesAndComboIdArray
                                        If lWriteRow = MaxCombinationRows Then                              '                                   If we have written MaxCombinationRows to TempArray then ...
                                            For ArrayRow = 1 To MaxCombinationRows                          '                                       Loop through the rows of TempArray
                                                CurrentRow = CurrentRow + 1                                 '                                           Increment CurrentRow
'
                                                For ArrayColumn = 1 To UBound(NamesAndComboIdArray, 2)      '                                           Loop to save the names & ComboIDs
                                                    NamesAndComboIdArray(CurrentRow, ArrayColumn) = _
                                                            TempArray(ArrayRow, ArrayColumn)                '
                                                Next                                                        '                                           Loop back
                                            Next                                                            '                                       Loop back
'
'-----------------------------------------------------------------------------------------------------------
'
' Write the TempArray to the sheet, apply duplicate name check formulas to each row & save resulting data range back to TempArray
                                            ActiveSheet.Cells(2, lFirstWriteColumn).Resize(UBound(TempArray, _
                                                    1), UBound(TempArray, 2)) = TempArray                   '                                       Write the TempArray to the sheet
'
                                            lLastRow = Cells(Rows.Count, lFirstWriteColumn).End(xlUp).Row   '                                       Get lLastRow
                                            lLastUsedColumn = Rows(1).Find("*", , xlFormulas, , _
                                                    xlByColumns, xlPrevious).Column                         '                                       Get LastUsedColumn in row 1
' Add formula to each row
                                            Set rngFormulaRange = Range(Cells(2, lLastUsedColumn + 1), _
                                                    Cells(lLastRow, lLastUsedColumn + 1))                   '                                       Set 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
                                            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) - 1)) Then                     '                                           If formula resulted in '#N/A' then ...
                                                    NoDupeRow = NoDupeRow + 1                               '                                               Increment NoDupeRow, this is the
'                                                                                                           '                                                       row of the TempArray2
                                                    For ArrayColumn = 1 To UBound(TempArray, 2) - 1         '                                               Loop through columns of
'                                                                                                           '                                                       TempArray, except last column
                                                        TempArray2(NoDupeRow, ArrayColumn) = _
                                                                TempArray(ArrayRow, ArrayColumn)            '                                                   Save values to TempArray2
                                                    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
                                            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 + 3) '                                       Clear results from TempArray2
'
'-----------------------------------------------------------------------------------------------------------
'
' Write TempArray2 to sheet, replace names with salary amounts, add up all of the salaries for each row & save results back to TempArray
                                            lLastRow = Cells(Rows.Count, lFirstWriteColumn).End(xlUp).Row   '                                       Get lLastRow
' Do the Salary/sum routine
' Add Sum Column
                                            Columns(lLastUsedColumn).Insert                                 '                                       Insert column for the 'Salary'
'
                                            Cells(1, lLastUsedColumn).Value = ChrW(931) & " Salary"         '                                       20 ... T
'
                                            For ArrayRow = 1 To UBound(SalarySheetShortenedArray, 1)        '                                       Replace names with salaries loop
                                                Range(Cells(2, lFirstWriteColumn), Cells(lLastRow, _
                                                        lLastWriteColumn)).Replace _
                                                        SalarySheetShortenedArray(ArrayRow, 1), _
                                                        SalarySheetShortenedArray(ArrayRow, 2), _
                                                        xlWhole, , False, , False, False                    '
                                            Next                                                            '                                       Loop back
'
                                            Set rngReplace = Nothing
'
                                            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 the MaxSalaryAllowed stipulation to NoDupeRowArray
                                            For ArrayRow = 1 To UBound(TempArray, 1)                        '                                       Loop through rows of TempArray
                                                If TempArray(ArrayRow, UBound(TempArray, 2) - 2) _
                                                        <= 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) - 1         '                                               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
'
'-----------------------------------------------------------------------------------------------------------
'
' 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 + 3)  '                                       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 save the Names and ComboIDs to NamesAndComboIdArray
    If TempArray(1, 1) <> vbNullString Then                                                                 ' If there are more cominations needing to be checked then ...
        For ArrayRow = 1 To MaxCombinationRows                                                              '   Loop through the rows of TempArray
            If TempArray(ArrayRow, 1) <> vbNullString Then                                                  '       If TempArray row is not blank then ...
                CurrentRow = CurrentRow + 1                                                                 '           Increment CurrentRow
'
                For ArrayColumn = 1 To UBound(NamesAndComboIdArray, 2)                                      '           Loop through the columns of NamesAndComboIdArray
                    NamesAndComboIdArray(CurrentRow, ArrayColumn) = TempArray(ArrayRow, ArrayColumn)        '               Save the data from TempArray row to NamesAndComboIdArray
                Next                                                                                        '           Loop back
            Else                                                                                            '       Else ...
                Exit For                                                                                    '           Exit the For loop
            End If
        Next                                                                                                '   Loop back
'
'-----------------------------------------------------------------------------------------------------------
'
' Write the TempArray to the sheet, apply duplicate name check formulas to each row & save resulting data range back to TempArray
        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
        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) - 1)) Then       '       If formula resulted in '#N/A' then ...
                NoDupeRow = NoDupeRow + 1                                                                   '           Increment NoDupeRow, this is the row of the TempArray2
'
                For ArrayColumn = 1 To UBound(TempArray, 2) - 1                                             '           Loop through columns of TempArray, except last column
                    TempArray2(NoDupeRow, ArrayColumn) = TempArray(ArrayRow, ArrayColumn)                   '               Save values to TempArray2
                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
'
'-----------------------------------------------------------------------------------------------------------
'
' Write TempArray2 to sheet, replace names with salary amounts, 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
'
' Do the Salary/sum routine
' Add Sum Column
        Columns(lLastUsedColumn).Insert                                                                     '   Insert column 20 ... U for the 'Salary'
'
        Cells(1, lLastUsedColumn).Value = ChrW(931) & " Salary"                                             '   20 ... T
'
        Set rngReplace = Range(Cells(2, lFirstWriteColumn), Cells(lLastRow, lLastWriteColumn))              '
'
        For ArrayRow = 1 To UBound(SalarySheetShortenedArray, 1)                                            '   Loop through rows of SalarySheetShortenedArray
            rngReplace.Replace What:=SalarySheetShortenedArray(ArrayRow, 1), _
            Replacement:=SalarySheetShortenedArray(ArrayRow, 2), _
            LookAt:=xlWhole, SearchOrder:=xlByRows, MatchCase:=False, _
            SearchFormat:=False, ReplaceFormat:=False                                                       '       put the different salaries on the sheet
        Next                                                                                                '   Loop back
'
        Set rngReplace = Nothing
'
        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) - 2) <= 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) - 1                                             '               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) - 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
'
'    If UBound(NoDupeRowArray, 1) > Rows.Count Then                                                          ' If there are > total rows allowed on a sheet remaining then ...
        SubArrays = Int((UBound(NoDupeRowArray, 1) - 1) / MaxRowsPerSubArray) + 1                           '   Determine number of SubArrays needed
'
        ReDim JaggedArray(1 To SubArrays)                                                                   '   Set the # of SubArrays in JaggedArray
'
        CurrentRow = 0                                                                                      '   Reset CurrentRow
'
' Create array(s) of combinations
        For SubArrayNumber = 1 To SubArrays                                                                 '   Loop through SubArrays
            ReDim arrOut(1 To MaxRowsPerSubArray, 1 To UBound(NoDupeRowArray, 2))                           '       Reset the arrOut
'
            For SubArrayRow = 1 To MaxRowsPerSubArray                                                       '       Loop through rows of arrOut
                CurrentRow = CurrentRow + 1                                                                 '           Increment CurrentRow, this is the row of the NoDupeRowArray
'
                If CurrentRow > UBound(NoDupeRowArray, 1) Then Exit For                                     '           If all of the rows have been processed then exit this For loop
'
                For ArrayColumn = 1 To UBound(NoDupeRowArray, 2)                                            '           Loop through columns of NoDupeRowArray
                    arrOut(SubArrayRow, ArrayColumn) = NoDupeRowArray(CurrentRow, ArrayColumn)              '               Save column value into arrOut
                Next                                                                                        '           Loop back
            Next                                                                                            '       Loop back
'
            JaggedArray(SubArrayNumber) = arrOut                                                            '       Save the arrOut to the JaggedArray
'
            Erase arrOut
        Next                                                                                                '   Loop back
'
' At this point, all of the remaining combinations have been loaded into the JaggedArray subArrays
'
' Write each subArray to the sheet, sort each row & save results back into the subArray
        For SubArrayNumber = 1 To SubArrays                                                                 '   Loop through SubArrays
            ActiveSheet.Cells(2, lFirstWriteColumn).Resize(UBound(JaggedArray(SubArrayNumber), 1), _
                    UBound(JaggedArray(SubArrayNumber), 2)) = JaggedArray(SubArrayNumber)                   '       Write the subArray to the sheet for sorting
'
            ActiveSheet.Sort.SortFields.Clear                                                               '
'
' Sort each row
            lLastRow = Cells(Rows.Count, lFirstWriteColumn).End(xlUp).Row                                   '       Get lLastRow
'
            Set rngSortRange = Range(Cells(2, lFirstWriteColumn), Cells(lLastRow, lLastWriteColumn))        '       Set the Range to be sorted
'
            For Each SortRowRange In rngSortRange.Rows                                                      '       Loop through each row of the range to be sorted
                SortRowRange.Sort Key1:=SortRowRange.Cells(1, 1), Order1:=xlAscending, _
                        Header:=xlNo, Orientation:=xlSortRows                                               '           Sort each row alphabetically
            Next                                                                                            '       Loop back
'
            Set rngSortRange = Nothing
            Set SortRowRange = Nothing
'
' Load the sorted data back into the subArray
            JaggedArray(SubArrayNumber) = ActiveSheet.Cells(2, lFirstWriteColumn).Resize(UBound( _
                    JaggedArray(SubArrayNumber), 1), UBound(JaggedArray(SubArrayNumber), 2))                '
'
            ActiveSheet.Cells(2, lFirstWriteColumn).Resize(UBound(JaggedArray(SubArrayNumber), 1), _
                 UBound(JaggedArray(SubArrayNumber), 2)).ClearContents                                      '       Clear the sort range
        Next                                                                                                '   Loop back
'
    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))             '
'
'    If UBound(NoDupeRowArray, 1) > Rows.Count Then                                                          ' If there are > total rows allowed on a sheet remaining then ...
'
' Join all of the sorted subArray unique rows back into 1 large array
'
        'Initialize the scripting dictionary
        Set oSD = CreateObject("Scripting.Dictionary")
        oSD.CompareMode = vbTextCompare
'
        CurrentRow = 0                                                                                      '   Reset CurrentRow
'
        For SubArrayNumber = 1 To SubArrays                                                                 '   Loop through the SubArrays
            For SubArrayRow = 1 To UBound(JaggedArray(SubArrayNumber), 1)                                   '       Loop through rows of each subArray in the JaggedArray
                oSD_KeyString = ""                                                                          '           Erase 'oSD_KeyString'
                Delimiter = ""                                                                              '           Erase 'Delimiter' of NoDupeSortedRowsArray
'
                For SubArrayColumn = 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'
'
' 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
'
        lFirstHTeamCol = lLastHSortColumn + 1                                                               '   31 ... AE
        lLastHTeamCol = Cells(1, Columns.Count).End(xlToLeft).Column                                        '   39 ... AM
'
        Set rngReplace2 = Range(Cells(2, lFirstHSortColumn), Cells(lLastRow, lLastHSortColumn))             '   22 ... V ... 30 ... AD
        Set rngReplace3 = Range(Cells(2, lFirstHTeamCol), Cells(lLastRow, lLastHTeamCol))                   '   31 ... AE ... 39 ... AM
'
        For ArrayRow = 1 To UBound(SalarySheetShortenedArray, 1)                                            '   Loop through rows of SalarySheetShortenedArray
'
'''''''''''''''''''''''''''''''''''''PROJECTION
            rngReplace2.Replace What:=SalarySheetShortenedArray(ArrayRow, 1), _
                Replacement:=SalarySheetShortenedArray(ArrayRow, 3), LookAt:=xlWhole, _
                SearchOrder:=xlByRows, MatchCase:=False, SearchFormat:=False, ReplaceFormat:=False          '
'
'
         '''''''''''''''''''''''''''''''''''''TEAM
            rngReplace3.Replace What:=SalarySheetShortenedArray(ArrayRow, 1), _
                Replacement:=SalarySheetShortenedArray(ArrayRow, 4), LookAt:=xlWhole, _
                SearchOrder:=xlByRows, MatchCase:=False, SearchFormat:=False, ReplaceFormat:=False          '
        Next                                                                                                '   Loop back
'
        Set rngReplace2 = Nothing
        Set rngReplace3 = Nothing
'
' Add Projection Column
        Cells(1, lLastHTeamCol + 1).Value = ChrW(931) & " Projection"                                       '   40 ... AN
' Add Team Stack Column
        Cells(1, lLastHTeamCol + 2).Value = ChrW(931) & " Stack"                                            '   41 ... AO
' Add Team Stack Pos
        Cells(1, lLastHTeamCol + 3).Value = ChrW(931) & " Stack POS"                                        '   42 ... AP
' Add 2nd Team Stack Column
        Cells(1, lLastHTeamCol + 4).Value = ChrW(931) & " Stack2"                                           '   43 ... AQ
' Add 2nd Team Stack Pos
        Cells(1, lLastHTeamCol + 5).Value = ChrW(931) & " Stack2 POS"                                       '   44 ... AR
' Filter 0-1
        Cells(1, lLastHTeamCol + 6).Value = ChrW(931) & " Filter"                                           '   45 ... AS
' Player 1 Filter
        Cells(1, lLastHTeamCol + 7).Value = ChrW(931) & " Player1"                                          '   46 ... AT
' Player 2 Filter
        Cells(1, lLastHTeamCol + 8).Value = ChrW(931) & " Player2"                                          '   47 ... AU
'
        With Range(Cells(2, lLastHTeamCol + 1), Cells(lLastRow, lLastHTeamCol + 1))
            .FormulaR1C1 = "=SUM(RC" & lFirstHSortColumn & ":RC" & lLastHSortColumn & ")"                   '       Projection formula
            Application.Calculate                                                                           '
            .Value = .Value                                                                                 '
        End With
'
        With Range(Cells(2, lLastHTeamCol + 2), Cells(lLastRow, lLastHTeamCol + 2))
            .FormulaR1C1 = "=INDEX(RC" & lFirstHTeamCol & ":RC" & lLastHTeamCol & ",MODE(MATCH(RC" & _
                    lFirstHTeamCol & ":RC" & lLastHTeamCol & ",RC" & lFirstHTeamCol & ":RC" & _
                    lLastHTeamCol & ",0)))"                                                                 '       Stack formula
            Application.Calculate                                                                           '
            .Value = .Value                                                                                 '
        End With
'
        With Range(Cells(2, lLastHTeamCol + 3), Cells(lLastRow, lLastHTeamCol + 3))
            .Formula2R1C1 = "=TEXTJOIN("","",1,IF(RC[-11]:RC[-3]=RC[-1],R1C[-11]:R1C[-3],""""))"            '       Stack POS
            Application.Calculate                                                                           '
            .Value = .Value                                                                                 '
        End With
'
        With Range(Cells(2, lLastHTeamCol + 4), Cells(lLastRow, lLastHTeamCol + 4))
            .Formula2R1C1 = "=IFERROR(INDEX(RC[-12]:RC[-4],MODE(IF((RC[-12]:RC[-4]<>"""")*" & _
                    "(RC[-12]:RC[-4]<>INDEX(RC[-12]:RC[-4],MODE(IF(RC[-12]:RC[-4]<>"""",MATCH(" & _
                    "RC[-12]:RC[-4],RC[-12]:RC[-4],0))))),MATCH(RC[-12]:RC[-4],RC[-12]:RC[-4],0)))),"""")"  '       Stack2 formula
            Application.Calculate                                                                           '
            .Value = .Value                                                                                 '
        End With
'
        With Range(Cells(2, lLastHTeamCol + 5), Cells(lLastRow, lLastHTeamCol + 5))
            .Formula2R1C1 = "=TEXTJOIN("","",1,IF(RC[-13]:RC[-5]=RC[-1],R1C[-13]:R1C[-5],""""))"            '
            Application.Calculate                                                                           '
            .Value = .Value                                                                                 '
        End With
'
'-------------------------------------------------------------------------------------------------------------------------------
'
' 9) "Filter" column added to column BB, "Player1" column added to column BC, "Player2" column added to column BD. Nothing is calculated in these
'    columns. Only Headers added. Currently not a used function for this project.
'
        With Range(Cells(2, lLastHTeamCol + 6), Cells(lLastRow, lLastHTeamCol + 6))                         '
        End With
'
        With Range(Cells(2, lLastHTeamCol + 7), Cells(lLastRow, lLastHTeamCol + 7))                         '
        End With
'
        With Range(Cells(2, lLastHTeamCol + 8), Cells(lLastRow, lLastHTeamCol + 8))                         '
        End With
    Else                                                                                                    '
        MsgBox "No rows qualified for further testing."                                                     '
'
        GoTo End_Sub
    End If
'
'-------------------------------------------------------------------------------------------------------------------------------
'
' 10) Removes all helper columns - U:AU. "Salary" column becomes column U. "Projection" column becomes column V. "Stack" column becomes column W. "Stack POS"
'    column becomes column X. "Stack 2" column becomes column Y. "Stack 2 POS" column becomes column Z. Filter column becomes column AA. "Player1" Column
'    becomes column AB. "Player2" column becomes column AC.. A Dialogue Box then pops open and provides combination info: Possible combinations,
'    unique combinations, duplicates removed, and the time to process. Data is then autofitted to the used range and printed to the "Worksheet".
'    OptimizeCode_End is then called, which is just turning back on screen updating and whatnot.
'
' Remove Salary Columns
'
    Range(Columns(lFirstHSortColumn), Columns(lLastHTeamCol)).Delete                                        ' Delete columns V:AM ... 22 thru 39
'
    If ComboID_Display = False Then Columns(lLastWriteColumn + 1).Delete                                    ' Delete ComboID column if user chose not to see it
'
    ActiveSheet.UsedRange.Columns.AutoFit                                                                   '
'
    sOutput = lLastIteration & vbTab & " possible combinations" & vbLf & lLastRow - 1 & vbTab & _
            " unique name combinations" & vbLf & IIf(lLastRow < lLastRow, lLastRow - lLastRow & vbTab & _
            " duplicate rows removed." & vbLf, "") & lLastRow - 1 & vbTab & " printed." & vbLf & vbLf & _
            ExcessCombinations & " combinations were not displayed due to sheet restraints" & _
            vbLf & vbLf & Format(Now() - dteStart, "hh:mm:ss") & " to process."                             '
'
    Debug.Print "Wrapping up completed in:" & Space(124) & Format(Now() - StartTime, "hh:mm:ss")            ' Display elapsed time for this process to the 'Immediate' window (CTRL+G) in VBE
'
    Debug.Print vbLf & sOutput                                                                              '
    MsgBox sOutput, , "Output Report"                                                                       '
'
End_Sub:
    Call OptimizeCode_End
End Sub



Public Function ReDimPreserve(ArrayNameToResize, NewRowUbound, NewColumnUbound)
'
' Code inspired by Control Freak
'
' Preserve Original data & LBounds & Redim both dimensions for a 2D array
'
' example usage of the function:
' ArrayName = ReDimPreserve(ArrayName,NewRowSize,NewColumnSize)
' ie.
' InputArray = ReDimPreserve(InputArray,10,20)
'
    Dim NewColumn                   As Long, NewRow                      As Long
    Dim OldColumnLbound             As Long, OldRowLbound                As Long
    Dim OldColumnUbound             As Long, OldRowUbound                As Long
    Dim NewResizedArray()           As Variant
'
    ReDimPreserve = False
'
    If IsArray(ArrayNameToResize) Then                                                                      ' If the variable is an array then ...
           OldRowLbound = LBound(ArrayNameToResize, 1)                                                      '   Save the original row Lbound to OldRowLbound
        OldColumnLbound = LBound(ArrayNameToResize, 2)                                                      '   Save the original column Lbound to OldColumnLbound
'
        ReDim NewResizedArray(OldRowLbound To NewRowUbound, OldColumnLbound To NewColumnUbound)             '   Create a New 2D Array with same Lbounds as the original array
'
        OldRowUbound = UBound(ArrayNameToResize, 1)                                                         '   Save row Ubound of original array
        OldColumnUbound = UBound(ArrayNameToResize, 2)                                                      '   Save column Ubound of original array
'
        For NewRow = OldRowLbound To NewRowUbound                                                           '   Loop through rows of original array
            For NewColumn = OldColumnLbound To NewColumnUbound                                              '       Loop through columns of original array
                If OldRowUbound >= NewRow And OldColumnUbound >= NewColumn Then                             '           If more data to copy then ...
                    NewResizedArray(NewRow, NewColumn) = ArrayNameToResize(NewRow, NewColumn)               '               Append rows/columns to NewResizedArray
                End If
            Next                                                                                            '       Loop back
        Next                                                                                                '   Loop back
'
        Erase ArrayNameToResize                                                                             '   Free up the memory the Original array was taking
'
        If IsArray(NewResizedArray) Then ReDimPreserve = NewResizedArray
    End If
End Function
```


----------



## cspengel (Dec 21, 2022)

johnnyL said:


> Here is the code:
> 
> 
> ```
> ...


Awesome! thanks Johnny. Will try it out later today. 🙂


----------



## cspengel (Dec 22, 2022)

Here is one test 


```
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.
```

Runs great! Gonna run a few more.


----------



## cspengel (Dec 22, 2022)

Code runs great Johnny. It does appear to be quicker too!   

I still receive popup saying "No rows qualified for further testing." if the combinations exceed the given capacity which prohibits the projections from being loaded. Not sure why that it, but not a big deal as I doubt I will ever actually try and fill the sheet.


----------



## johnnyL (Dec 22, 2022)

cspengel said:


> Code runs great Johnny. It does appear to be quicker too!
> 
> I still receive popup saying "No rows qualified for further testing." if the combinations exceed the given capacity which prohibits the projections from being loaded. Not sure why that it, but not a big deal as I doubt I will ever actually try and fill the sheet.
> 
> ...



Not sure why you would get 'kicked' to 'No rows qualified for further testing.' Can you provide a sample name list, as short as possible, that produces that result?


----------



## johnnyL (Dec 22, 2022)

cspengel said:


> Here is one test
> 
> 
> ```
> ...



That is amazing compared to where you started at.  10 million combinations now, Wow.

I think I have exhausted my current knowledge of speeding up the script, that I can think of right now.

You might want to start a new thread asking if using 'Enum' would speed the script up further. From my very limited knowledge of 'Enum', 'Enum' is much faster than comparing strings, which is what a lot of the current code does. If not 'Enum', possibly another approach? A new thread that asks for a faster solution to the current code that is working for you will also have more members look into it, hopefully. Like I said a while ago, your original code made my head hurt. 

Unfortunatly, I have never used 'Enum' so I can't provide any help with that approach, but I have read it is way faster than comparing strings.

Since this thread has appeared to reach its limits, please update the solution that you currently have marked as the solution with the post that best answers your original question.


----------



## cspengel (Dec 22, 2022)

johnnyL said:


> That is amazing compared to where you started at.  10 million combinations now, Wow.
> 
> I think I have exhausted my current knowledge of speeding up the script, that I can think of right now.
> 
> ...


Thanks johnny for all your help! I may start a new thread in the future regarding your suggestion, but am happy with the results now   .  I changed the solution to your latest posted code & maybe i'll see ya around on the forums 😁 Thanks again!


----------



## cspengel (Nov 25, 2022)

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



```
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
```


----------



## johnnyL (Dec 22, 2022)

Glad to help.


----------



## johnnyL (Dec 24, 2022)

Sorry, can't stay away for some reason. ;(

Should be able to make it about 25% faster yet if my current thinking pans out.


----------



## johnnyL (Dec 24, 2022)

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.


----------



## cspengel (Dec 24, 2022)

johnnyL said:


> 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.


----------



## johnnyL (Dec 24, 2022)

johnnyL said:


> ```
> 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.
> ...



Results from newest 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.
```



johnnyL said:


> ```
> 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.
> ...



Results from newest 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.


```
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
```


----------



## cspengel (Dec 25, 2022)

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 😊


----------



## cspengel (Dec 26, 2022)

johnnyL said:


> Results from newest 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.
> ...


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 👏


----------



## johnnyL (Dec 26, 2022)

You didn't post your results 

Also, please update the thread answer to the one you like best.


----------



## cspengel (Dec 26, 2022)

My bad haha. 

Here ya go 


```
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.
```


----------



## johnnyL (Dec 26, 2022)

WOW !!! The closest I can find to compare to is, from you in post #124 about the code in post #122:


cspengel said:


> ```
> 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.
> ...



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



What you posted in post #136 about the code in post #134:


cspengel said:


> ```
> 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
> ...



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


What you posted in post #149 about the code in post #145:


cspengel said:


> ```
> 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
> ...



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.


----------



## cspengel (Nov 25, 2022)

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



```
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
```


----------



## cspengel (Dec 26, 2022)

johnnyL said:


> WOW !!! The closest I can find to compare to is, from you in post #124 about the code in post #122:
> 
> 
> That equates to 9144576 possible combinations / 4132 seconds = 2,213 combinations/second
> ...


Wow ! It's amazing how much you've improved even your own code and to think where the code was from the beginning! 😃 

Sounds great 😉


----------



## johnnyL (Dec 26, 2022)

If memory serves me correct, original code rated at about 640 combinations/second.

So the most recent code posted would run about 24X faster than the original code.


----------

