Help with max rows of a million+

[cspengel]

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]

Link to workbook is here

 

[cspengel]

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]

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]

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]

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]

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]

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]

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?

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]

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'

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]

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?

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