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]

Can you provide some test data via XL2BB?

 

[cspengel]

Can you provide some test data via XL2BB?

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

Sheet name: "Worksheet"

3game.xlsm
	A	B	C	D	E	F	G	H	I
1	QB	RB	RB2	WR1	WR2	WR3	TE	FLEX	DST
2	Josh Allen	Saquon Barkley	Saquon Barkley	Stefon Diggs	David Sills V	Stefon Diggs	T.J. Hockenson	Saquon Barkley	Buffalo Bills
3		Rhamondre Stevenson	Rhamondre Stevenson	Justin Jefferson	Jalen Reagor	Justin Jefferson	Dalton Schultz	Rhamondre Stevenson	Minnesota Vikings
4		Dalvin Cook	Dalvin Cook	CeeDee Lamb	Marcus Johnson	CeeDee Lamb	Dawson Knox	Dalvin Cook	New York Giants
5		Tony Pollard	Tony Pollard	Amon-Ra St. Brown	Khalil Shakir	Amon-Ra St. Brown	Hunter Henry	Tony Pollard
6			Devin Singletary		Kendrick Bourne	Gabe Davis		Devin Singletary
7			Ezekiel Elliott		Lawrence Cager	Jakobi Meyers		Ezekiel Elliott
8			Jamaal Williams		Nelson Agholor	Adam Thielen		Jamaal Williams
9			D'Andre Swift		Kenny Golladay	Darius Slayton		Stefon Diggs
10			Damien Harris		Isaiah Hodgins	Michael Gallup		Justin Jefferson
11			James Cook			Isaiah McKenzie		CeeDee Lamb
12						Kalif Raymond		Amon-Ra St. Brown
13						Richie James Jr.		Gabe Davis
14						K.J. Osborn		Jakobi Meyers
15								Adam Thielen
Worksheet

Sheet name: "Salary"

3game.xlsm
	A	B	C	D	E
1	Name	Salary	Projection	TEAM	Column1
2	Josh Allen	9500	7.77	BUF	30.92
3	Justin Jefferson	8600	20.49	MIN	24.84
4	Amon-Ra St. Brown	7600	1.2	NYG	23.4
5	Mac Jones	6500	0	NYG	23.28
6	Kirk Cousins	7400	0	MIN	22.86
7	Isaiah McKenzie	5200	0.79	DAL	19.3
8	Stefon Diggs	9300	0	DET	17.7
9	Jared Goff	6900	0	NE	17.6
10	Dalton Schultz	5800	0	DET	17.1
11	Dak Prescott	8000	0	BUF	16.84
12	Adam Thielen	5900	0	DET	16.6
13	Ezekiel Elliott	7000	7.18	DAL	16
14	Rhamondre Stevenson	7200	13.92	NE	15.7
15	Nelson Agholor	5100	0	BUF	15.5
16	CeeDee Lamb	7900	0	DET	14.7
17	Daniel Jones	7500	0	NE	14.52
18	Hunter Henry	4900	0	MIN	13.8
19	Saquon Barkley	8800	2.26	DAL	13.2
20	T.J. Hockenson	6300	5.06	NYG	12.8
21	Richie James Jr.	5400	0	DET	12.6
22	Jamaal Williams	7100	23.65	BUF	10.6
23	DeVante Parker	5400	7.14	NE	10
24	Minnesota Vikings	4000	0	DAL	9
25	Michael Gallup	5700	4.09	DET	8.8
26	DJ Chark Jr.	5000	17.56	BUF	8.6
27	Devin Singletary	6900	0	NYG	8.5
28	D'Andre Swift	6200	11.65	BUF	8.3
29	Darius Slayton	6400	0	DAL	7.8
30	Jakobi Meyers	6700	0	DET	7.7
31	Dalvin Cook	7800	1.21	MIN	7.6
32	Jake Ferguson	4400	0	NYG	7.2
33	Tony Pollard	8500	12.75	DAL	7.1
34	Peyton Hendershot	4300	0	DAL	6.2
35	Buffalo Bills	4400	5.95	DET	6
36	Kene Nwangwu	4700	0	MIN	6
37	Gary Brightwell	4600	0.31	NYG	5.9
38	Gabe Davis	7200	13.17	BUF	5.8
39	Kalif Raymond	5500	18.86	DAL	5.5
40	Detroit Lions	3200	3.2	NE	5
41	Isaiah Hodgins	5100	7.66	MIN	4.6
42	Kendrick Bourne	4900	15.04	DET	4.4
43	Dallas Cowboys	5000	0	DAL	4
44	New York Giants	3500	2.79	NYG	3
45	Jalen Reagor	4700	1.36	DET	3
46	New England Patriots	4200	0	DET	3
47	Johnny Mundt	4300	0	BUF	3
48	Chris Myarick	4200	16.2	MIN	2.8
49	James Cook	5500	0	DET	2.8
50	Dawson Knox	5500	3.91	NYG	2.7
51	James Mitchell	4200	0	NE	2.7
52	Lawrence Cager	4800	15.69	NYG	2.5
53	Justin Jackson	5200	0	NYG	2.4
54	Matt Breida	5100	7.95	DAL	2
55	K.J. Osborn	5300	0	MIN	1.8
56	Brock Wright	4600	15.81	DET	1.6
57	Damien Harris	6400	0	NE	1.6
58	Tanner Hudson	4300	0	DAL	1.5
59	Alexander Mattison	5000	3.61	MIN	1.1
60	Quintin Morris	4200	7.18	DAL	0.8
61	Nyheim Hines	4900	8.71	NE	0.3
62	Kenny Golladay	5300	15.72	MIN	0
63	Nick Mullens	6100	14.62	DAL	0
64	Nick Ralston	4000	14.31	NYG	0
65	Jeremiah Hall	4500	14	NE	0
66	Matt Barkley	6000	11.81	DAL	0
67	Pierre Strong Jr.	4500	11.7	DET	0
68	Sean McKeon	4100	11.56	DET	0
69	Garrett Griffin	4000	10.13	MIN	0
70	Hunter Thedford	4000	10.11	NYG	0
71	Thomas Hennigan	4500	8.63	BUF	0
72	Dennis Houston	4500	8.34	NE	0
73	Josh Hammond	4500	7.24	NE	0
74	Jonnu Smith	4700	7.11	BUF	0
75	Tre Nixon	4500	6.53	DET	0
76	Travis Toivonen	4500	6.18	NYG	0
77	T.J. Vasher	4500	6.01	MIN	0
78	Marcus Johnson	4700	5.91	NYG	0
79	Tyrod Taylor	6100	5.84	DAL	0
80	Duke Johnson	4500	5.64	MIN	0
81	Nick Muse	4000	5.58	BUF	0
82	Stanley Berryhill	4500	5.57	NE	0
83	Bailey Zappe	6100	4.78	DET	0
84	Jason Cabinda	4500	4.51	NE	0
85	Matt Sokol	4000	4.3	BUF	0
86	Josh Johnson	4500	4.14	DET	0
87	Brian Hoyer	6000	3.73	DET	0
88	Isaiah Coulter	4500	3.3	NE	0
89	Khalil Shakir	4600	3.26	BUF	0
90	David Sills V	4600	3.23	DAL	0
91	Brian Lewerke	6000	2.98	NYG	0
92	Sandro Platzgummer	4500	2.59	DAL	0
93	Lil'Jordan Humphrey	4600	2.45	DET	0
94	Tyquan Thornton	5300	2.11	NE	0
95	Antonio Callaway	4500	2.09	NYG	0
96	Qadree Ollison	4600	1.95	NYG	0
97	Jameson Williams	4500	1.86	DET	0
98	Ryan Nall	4500	1.46	NYG	0
99	Tanner Gentry	4500	1.41	MIN	0
100	KaVontae Turpin	4600	1.4	BUF	0
101	C.J. Ham	4500	0.94	MIN	0
102	Nate Sudfeld	6000	0.91	MIN	0
103	Jake Kumerow	4500	0.82	DAL	0
104	Taiwan Jones	4500	0.53	BUF	0
105	Collin Johnson	4500	0.35	NE	0
Salary

 

[johnnyL]

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

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

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

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

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

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

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

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


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

 

[cspengel]

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

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

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

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

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

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

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

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


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

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

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

 Set wksData = ThisWorkbook.Sheets("Worksheet")
    Set names = Sheets("Salary")
    'Check for salary worksheet
    For Each wks In ThisWorkbook.Worksheets
        If wks.Name = "Salary" Then bFoundSalary = True
    Next
    If Not bFoundSalary Then
        MsgBox "The workbook must contain a worksheet named 'Salary' with data starting in row 2 " & _
            "that consists of column A containing each name in the name/column layout worksheet " & _
            "and column B containng their salary."
        GoTo End_Sub
    End If
    
    'Make sure each name has a corresponding salary entry
    'Initialize the scripting dictionary
    Set oSD = CreateObject("Scripting.Dictionary")
    oSD.CompareMode = vbTextCompare
    'Inventory names on the main worksheet
    For Each rngCell In ActiveSheet.Range("A1").CurrentRegion.Offset(1, 0)
        rngCell.Value = Trim(rngCell.Value)
        If rngCell.Value <> vbNullString Then
            oSD.Item(rngCell.Value) = oSD.Item(rngCell.Value) + 1
        End If
    Next
    'Remove names on the Salary worksheet
    With Worksheets("Salary")
        For Each rngCell In .Range("A2:A" & .Cells(Rows.Count, 1).End(xlUp).Row)
            rngCell.Value = Trim(rngCell.Value)
            If oSD.exists(rngCell.Value) Then
                oSD.Remove rngCell.Value
            End If
        Next
    End With
    
    'Any names not accounted for?
    If oSD.Count <> 0 Then
        varK = oSD.keys
        For lIndex = LBound(varK) To UBound(varK)
            sMissingSalary = sMissingSalary & ", " & varK(lIndex)
        Next
        sMissingSalary = Mid(sMissingSalary, 3)
        sOutput = "The following names on the main worksheet do not have a corresponding entry on the 'Salary' worksheet." & vbLf & vbLf & _
            sMissingSalary
        MsgBox sOutput
        Debug.Print sOutput
        GoTo End_Sub
    End If
    
    sErrorMsg = "Ensure a Worksheet is active with a header row starting in A1" & _
        "and names under each header entry."
    
    If TypeName(ActiveSheet) <> "Worksheet" Then
        bShowError = True
    End If
    
    If bShowError Then
        MsgBox sErrorMsg, , "Problems Found in Data"
        GoTo End_Sub
    End If
    
    lLastColumn = Range("A1").CurrentRegion.Columns.Count
    lLastUsedColumn = ActiveSheet.UsedRange.Columns.Count
    ReDim aryNames(1 To 2, 1 To lLastColumn)    '1 holds the in-use entry row
                                                
    'How many combinations? (Order does not matter)
    lLastIteration = 1
    For lColumnIndex = 1 To lLastColumn
        aryNames(1, lColumnIndex) = 2
        aryNames(2, lColumnIndex) = Cells(Rows.Count, lColumnIndex).End(xlUp).Row
        lLastIteration = lLastIteration * (aryNames(2, lColumnIndex) - 1)
    Next
    
    lRefColumn = lLastColumn + 1
    lFirstWriteColumn = lLastColumn + 2
    lLastWriteColumn = (2 * lLastColumn) + 1
    
    Select Case MsgBox("Process a " & lLastColumn & " column table with " & _
        lLastIteration & " possible combinations?" & vbLf & vbLf & _
        "WARNING: Columns right of the input range will be erased before continuing.", vbOKCancel + vbCritical + _
        vbDefaultButton2, "Process table?")
    Case vbCancel
        GoTo End_Sub
    End Select

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

'Clear all columns right of input range
    If lLastUsedColumn > lLastColumn Then
        Range(Cells(1, lLastColumn + 1), Cells(1, lLastUsedColumn)).EntireColumn.ClearContents
    End If
    Cells(1, lLastWriteColumn + 1).Value = "ComboID"
    
    'Add Output Header
    Range(Cells(1, 1), Cells(1, lLastColumn)).Copy Destination:=Cells(1, lFirstWriteColumn)
    
    'Start checking combinations
    lWriteRow = 2
    For lIterationCount = 1 To lLastIteration
        If lIterationCount / 1000 = lIterationCount \ 1000 Then Application.StatusBar = _
            lIterationCount & " / " & lLastIteration
            
        'Reset the Dupe Name flag
        bDupeName = False
        
        'Check Active Combo for Dupe Names
        'Initialize the scripting dictionary
        Set oSD = CreateObject("Scripting.Dictionary")
        oSD.CompareMode = vbTextCompare
        
        'Load names into scripting dictionary
        For lColumnIndex = lLastColumn To 1 Step -1
            sName = Cells(aryNames(1, lColumnIndex), lColumnIndex).Value
            oSD.Item(sName) = oSD.Item(sName) + 1
        Next
        
        'If there are names, and at least one duplicate, set the bDupeName flag
        If oSD.Count > 0 Then
            varK = oSD.keys
            varI = oSD.Items
            For lIndex = 1 To oSD.Count
                If varI(lIndex - 1) > 1 Then
                    bDupeName = True: Exit For
                End If
            Next
        End If
        
        
        If Not bDupeName Then
            'The current row had names and no duplicates
            'Print Active Combo to the lWriteRow row
            For lColumnIndex = lLastColumn To 1 Step -1
                lWriteColumn = lColumnIndex + lLastColumn + 2
                Set rngWrite = Range(Cells(lWriteRow, lFirstWriteColumn), Cells(lWriteRow, lLastWriteColumn))
                Cells(lWriteRow, lRefColumn + lColumnIndex).Value = Cells(aryNames(1, lColumnIndex), lColumnIndex).Value
            Next
            
            'Uncomment next row to see the lIterationCount for the printed row
            Cells(lWriteRow, lLastWriteColumn + 1).Value = lIterationCount
            
            'Point to the next blank row
            lWriteRow = lWriteRow + 1
            
        End If

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

End If
    
        'Increment Counters
        'Whether the line had duplicates or not, move to the next name in the
        '  rightmost column, if it was ag the last name, go to the first name in that column and
        '  move the name in the column to the left down to the next name (recursive check if THAT
        '  column was already using the last name for remaining columns to the left)
        aryNames(1, lLastColumn) = aryNames(1, lLastColumn) + 1
        If aryNames(1, lLastColumn) > aryNames(2, lLastColumn) Then
            bCarry = True
            lCarryColumn = lLastColumn
            Do While bCarry = True And lCarryColumn > 0
                aryNames(1, lCarryColumn) = 2
                bCarry = False
                lCarryColumn = lCarryColumn - 1
                If lCarryColumn = 0 Then Exit Do
                aryNames(1, lCarryColumn) = aryNames(1, lCarryColumn) + 1
                If aryNames(1, lCarryColumn) > aryNames(2, lCarryColumn) Then bCarry = True
            Loop
        End If
        
        'Check counter values (for debug)
'        Debug.Print lWriteRow,
'        For lPrint = 1 To lLastColumn
'            Debug.Print aryNames(1, lPrint) & ", ";
'        Next
'        Debug.Print
        DoEvents

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

    'Copy row names to right so that each copied row can be sorted alphabetically left to right
    '  this will allow the Excel remove duplicate fuction to remove rows that have identical names
    '  in all of their sorted columns.
    lLastRow = Cells(Rows.Count, lFirstWriteColumn).End(xlUp).Row
    Range(Cells(1, lFirstWriteColumn), Cells(lLastRow, lLastWriteColumn)).Copy Destination:=Cells(1, lLastWriteColumn + 2) ''SALARY
    lFirstHSortColumn = lLastWriteColumn + 2
    lLastHSortColumn = Cells(1, Columns.Count).End(xlToLeft).Column
    
    Range(Cells(1, lFirstWriteColumn), Cells(lLastRow, lLastWriteColumn)).Copy Destination:=Cells(1, lLastHSortColumn + 1) ''PROJECTION
    lFirstHSortColumn2 = lLastHSortColumn + 1
    lLastHSortColumn2 = Cells(1, Columns.Count).End(xlToLeft).Column
     
    Range(Cells(1, lFirstWriteColumn), Cells(lLastRow, lLastWriteColumn)).Copy Destination:=Cells(1, lLastHSortColumn2 + 1) ''TEAM
    lFirstHTeamCol = lLastHSortColumn2 + 1
    lLastHTeamCol = Cells(1, Columns.Count).End(xlToLeft).Column

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

'Assumes the 'Salary' worksheet has names in the column A and salaries in column B starting in row 2
    'Replace HSort names with salary
    With Worksheets("Salary") '''' SALARY
        lLastSalaryRow = .Cells(.Rows.Count, 1).End(xlUp).Row
    End With
    Set rngReplace = Range(Cells(2, lFirstHSortColumn), Cells(lLastRow, lLastHSortColumn))
    For lRowIndex = 2 To lLastSalaryRow
        rngReplace.Replace What:=Worksheets("Salary").Cells(lRowIndex, 1).Value, _
            Replacement:=Worksheets("Salary").Cells(lRowIndex, 2).Value, LookAt:=xlWhole, _
            SearchOrder:=xlByRows, MatchCase:=False, SearchFormat:=False, _
            ReplaceFormat:=False
     Next
     lLastRowDeDuped = Cells(Rows.Count, lFirstWriteColumn).End(xlUp).Row
     'Add Sum Column
   Cells(1, lLastHTeamCol + 1).Value = ChrW(931) & " Salary"
    With Range(Cells(2, lLastHTeamCol + 1), Cells(lLastRowDeDuped, lLastHTeamCol + 1))
        .FormulaR1C1 = "=SUM(RC" & lFirstHSortColumn & ":RC" & lLastHSortColumn & ")"
        Application.Calculate
        .Value = .Value
        End With
        
   lLastRow = Cells(Rows.Count, lFirstWriteColumn).End(xlUp).Row
        
        With wksData
        .Range("A2:I26").Cut names.Range("G2")
        Application.CutCopyMode = False
      End With
        With wksData
        'Start from cell A1 (1, 1) and assign to the last row and last column
        Set rngDataBlock = .Range(.Cells(1, lLastHTeamCol + 1), .Cells(lLastRow, lLastHTeamCol + 1))
    End With
        x = 60000
        Application.DisplayAlerts = False
        With rngDataBlock
            .AutoFilter Field:=1, Criteria1:=">" & x
            On Error Resume Next
            .Range(Cells(2, lFirstWriteColumn), Cells(lLastRow, lLastHTeamCol + 9)).Delete Shift:=xlUp
        End With
    Application.DisplayAlerts = True
    
    With names
    .Range("G2:O26").Cut wksData.Range("A2")
    Application.CutCopyMode = False
    End With

     
    'Turn off the Autofilter safely
    With wksData
        .AutoFilterMode = False
        If .FilterMode = True Then
            .ShowAllData
        End If
    End With

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

'Check for duplicate rows in HSort Columns
    '  Can only happen if names are duplicated within an input column
    '  Build aryDeDupe  -- Array(1, 2, 3,...n)  -- to exclude iteration # column

    lLastRow = Cells(Rows.Count, lFirstWriteColumn).End(xlUp).Row
    ReDim aryDeDupe(0 To lLastHSortColumn - lFirstHSortColumn)
    lIndex = 0
    For lColumnIndex = lFirstHSortColumn To lLastHSortColumn
        aryDeDupe(lIndex) = CInt(lColumnIndex - lFirstWriteColumn + 1)
        lIndex = lIndex + 1
    Next
    ActiveSheet.Cells(1, lFirstWriteColumn).CurrentRegion.RemoveDuplicates Columns:=(aryDeDupe), Header:=xlYes
    'Above line won't work unless there are parens around the Columns argument ?????
    
    lLastRowDeDuped = Cells(Rows.Count, lFirstWriteColumn).End(xlUp).Row

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

 '''''''''''''''''''''''''''''''''''''PROJECTION
     With Worksheets("Salary")
        lLastSalaryRow = .Cells(.Rows.Count, 1).End(xlUp).Row
    End With
    Set rngReplace = Range(Cells(2, lFirstHSortColumn2), Cells(lLastRow, lLastHSortColumn2))
    For lRowIndex2 = 2 To lLastSalaryRow
        rngReplace.Replace What:=Worksheets("Salary").Cells(lRowIndex2, 1).Value, _
            Replacement:=Worksheets("Salary").Cells(lRowIndex2, 3).Value, LookAt:=xlWhole, _
            SearchOrder:=xlByRows, MatchCase:=False, SearchFormat:=False, _
            ReplaceFormat:=False
    Next '''''''''''''''''''''''''''
    
         '''''''''''''''''''''''''''''''''''''TEAM
     With Worksheets("Salary")
        lLastSalaryRow = .Cells(.Rows.Count, 1).End(xlUp).Row
    End With
    Set rngReplace = Range(Cells(2, lFirstHTeamCol), Cells(lLastRow, lLastHTeamCol))
    For lRowIndex2 = 2 To lLastSalaryRow
        rngReplace.Replace What:=Worksheets("Salary").Cells(lRowIndex2, 1).Value, _
            Replacement:=Worksheets("Salary").Cells(lRowIndex2, 4).Value, LookAt:=xlWhole, _
            SearchOrder:=xlByRows, MatchCase:=False, SearchFormat:=False, _
            ReplaceFormat:=False
    Next '''''''''''''''''''''''''''
    
    
    ''Add Projection Column
    Cells(1, lLastHTeamCol + 2).Value = ChrW(931) & " Projection"
    With Range(Cells(2, lLastHTeamCol + 2), Cells(lLastRowDeDuped, lLastHTeamCol + 2))
        .FormulaR1C1 = "=SUM(RC" & lFirstHSortColumn2 & ":RC" & lLastHSortColumn2 & ")"
        Application.Calculate
        .Value = .Value
    End With
    
     ''Add Team Stack Column
    Cells(1, lLastHTeamCol + 3).Value = ChrW(931) & " Stack"
    With Range(Cells(2, lLastHTeamCol + 3), Cells(lLastRowDeDuped, lLastHTeamCol + 3))
        .FormulaR1C1 = "=INDEX(RC" & lFirstHTeamCol & ":RC" & lLastHTeamCol & ",MODE(MATCH(RC" & lFirstHTeamCol & ":RC" & lLastHTeamCol & ",RC" & lFirstHTeamCol & ":RC" & lLastHTeamCol & ",0)))"
        Application.Calculate
        .Value = .Value
    End With
    
    ''Add Team Stack Pos
    Cells(1, lLastHTeamCol + 4).Value = ChrW(931) & " Stack POS"
    With Range(Cells(2, lLastHTeamCol + 4), Cells(lLastRowDeDuped, lLastHTeamCol + 4))
    
    .Formula2R1C1 = "=TEXTJOIN("","",1,IF(RC[-12]:RC[-4]=RC[-1],R1C[-12]:R1C[-4],""""))"
        Application.Calculate
        .Value = .Value
    End With
    
    ''Add 2nd Team Stack Column
    Cells(1, lLastHTeamCol + 5).Value = ChrW(931) & " Stack2"
    With Range(Cells(2, lLastHTeamCol + 5), Cells(lLastRowDeDuped, lLastHTeamCol + 5))
        .Formula2R1C1 = "=IFERROR(INDEX(RC[-13]:RC[-5],MODE(IF((RC[-13]:RC[-5]<>"""")*(RC[-13]:RC[-5]<>INDEX(RC[-13]:RC[-5],MODE(IF(RC[-13]:RC[-5]<>"""",MATCH(RC[-13]:RC[-5],RC[-13]:RC[-5],0))))),MATCH(RC[-13]:RC[-5],RC[-13]:RC[-5],0)))),"""")"
        Application.Calculate
        .Value = .Value
    End With
    
    ''Add 2nd Team Stack Pos
    Cells(1, lLastHTeamCol + 6).Value = ChrW(931) & " Stack2 POS"
    With Range(Cells(2, lLastHTeamCol + 6), Cells(lLastRowDeDuped, lLastHTeamCol + 6))
    
    .Formula2R1C1 = "=TEXTJOIN("","",1,IF(RC[-12]:RC[-4]=RC[-1],R1C[-12]:R1C[-4],""""))"
        Application.Calculate
        .Value = .Value
    End With

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

'Filter 0-1
    Cells(1, lLastHTeamCol + 7).Value = ChrW(931) & " Filter"
    With Range(Cells(2, lLastHTeamCol + 7), Cells(lLastRowDeDuped, lLastHTeamCol + 7))
    
    End With
    
    'Player 1 Filter
    Cells(1, lLastHTeamCol + 8).Value = ChrW(931) & " Player1"
    With Range(Cells(2, lLastHTeamCol + 8), Cells(lLastRowDeDuped, lLastHTeamCol + 8))
    
    End With
    
    'Player 2 Filter
    Cells(1, lLastHTeamCol + 9).Value = ChrW(931) & " Player2"
    With Range(Cells(2, lLastHTeamCol + 9), Cells(lLastRowDeDuped, lLastHTeamCol + 9))
    
    End With

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

'Remove Salary Columns
    Range(Cells(2, lFirstHSortColumn), Cells(lLastRowDeDuped, lLastHTeamCol)).EntireColumn.Delete

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

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

 

[johnnyL]

Here is the first couple of explanations you gave:

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

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



The following is more specific & what I would like to see from you, as an example:
1) Take all the names entered on the "Worksheet" (A2:Ix) sheet and check to see if all of those names also have a salary listed on the "Salary" sheet. If any of the names from "Worksheet" are not on the "Salary" sheet, it ends Sub. If all the names are on the salary sheet and there are corresponding salaries for each of those names, a pop up box will appear letting you know how many combinations to expect.

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



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


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

 

[cspengel]

Here is the first couple of explanations you gave:

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

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



The following is more specific & what I would like to see from you, as an example:
1) Take all the names entered on the "Worksheet" (A2:Ix) sheet and check to see if all of those names also have a salary listed on the "Salary" sheet. If any of the names from "Worksheet" are not on the "Salary" sheet, it ends Sub. If all the names are on the salary sheet and there are corresponding salaries for each of those names, a pop up box will appear letting you know how many combinations to expect.

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



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


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

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

 

[johnnyL]

Ok, I will await your next clarification post.

 

[cspengel]

The following is more specific & what I would like to see from you, as an example:
1) Take all the names entered on the "Worksheet" (A2:Ix) sheet and check to see if all of those names also have a salary listed on the "Salary" sheet. If any of the names from "Worksheet" are not on the "Salary" sheet, it ends Sub. If all the names are on the salary sheet and there are corresponding salaries for each of those names, a pop up box will appear letting you know how many combinations to expect.

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

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

'Increment Counters
        'Whether the line had duplicates or not, move to the next name in the
        '  rightmost column, if it was ag the last name, go to the first name in that column and
        '  move the name in the column to the left down to the next name (recursive check if THAT
        '  column was already using the last name for remaining columns to the left)
        aryNames(1, lLastColumn) = aryNames(1, lLastColumn) + 1
        If aryNames(1, lLastColumn) > aryNames(2, lLastColumn) Then
            bCarry = True
            lCarryColumn = lLastColumn
            Do While bCarry = True And lCarryColumn > 0
                aryNames(1, lCarryColumn) = 2
                bCarry = False
                lCarryColumn = lCarryColumn - 1
                If lCarryColumn = 0 Then Exit Do
                aryNames(1, lCarryColumn) = aryNames(1, lCarryColumn) + 1
                If aryNames(1, lCarryColumn) > aryNames(2, lCarryColumn) Then bCarry = True
            Loop
        End If
        
        'Check counter values (for debug)
'        Debug.Print lWriteRow,
'        For lPrint = 1 To lLastColumn
'            Debug.Print aryNames(1, lPrint) & ", ";
'        Next
'        Debug.Print
        DoEvents

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

'Copy row names to right so that each copied row can be sorted alphabetically left to right
    '  this will allow the Excel remove duplicate fuction to remove rows that have identical names
    '  in all of their sorted columns.
    lLastRow = Cells(Rows.Count, lFirstWriteColumn).End(xlUp).Row
    Range(Cells(1, lFirstWriteColumn), Cells(lLastRow, lLastWriteColumn)).Copy Destination:=Cells(1, lLastWriteColumn + 2) ''SALARY
    lFirstHSortColumn = lLastWriteColumn + 2
    lLastHSortColumn = Cells(1, Columns.Count).End(xlToLeft).Column
    
    Range(Cells(1, lFirstWriteColumn), Cells(lLastRow, lLastWriteColumn)).Copy Destination:=Cells(1, lLastHSortColumn + 1) ''PROJECTION
    lFirstHSortColumn2 = lLastHSortColumn + 1
    lLastHSortColumn2 = Cells(1, Columns.Count).End(xlToLeft).Column
     
    Range(Cells(1, lFirstWriteColumn), Cells(lLastRow, lLastWriteColumn)).Copy Destination:=Cells(1, lLastHSortColumn2 + 1) ''TEAM
    lFirstHTeamCol = lLastHSortColumn2 + 1
    lLastHTeamCol = Cells(1, Columns.Count).End(xlToLeft).Column

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

'Assumes the 'Salary' worksheet has names in the column A and salaries in column B starting in row 2
    'Replace HSort names with salary
    With Worksheets("Salary") '''' SALARY
        lLastSalaryRow = .Cells(.Rows.Count, 1).End(xlUp).Row
    End With
    Set rngReplace = Range(Cells(2, lFirstHSortColumn), Cells(lLastRow, lLastHSortColumn))
    For lRowIndex = 2 To lLastSalaryRow
        rngReplace.Replace What:=Worksheets("Salary").Cells(lRowIndex, 1).Value, _
            Replacement:=Worksheets("Salary").Cells(lRowIndex, 2).Value, LookAt:=xlWhole, _
            SearchOrder:=xlByRows, MatchCase:=False, SearchFormat:=False, _
            ReplaceFormat:=False
     Next
     lLastRowDeDuped = Cells(Rows.Count, lFirstWriteColumn).End(xlUp).Row
     'Add Sum Column
   Cells(1, lLastHTeamCol + 1).Value = ChrW(931) & " Salary"
    With Range(Cells(2, lLastHTeamCol + 1), Cells(lLastRowDeDuped, lLastHTeamCol + 1))
        .FormulaR1C1 = "=SUM(RC" & lFirstHSortColumn & ":RC" & lLastHSortColumn & ")"
        Application.Calculate
        .Value = .Value
        End With
        
   lLastRow = Cells(Rows.Count, lFirstWriteColumn).End(xlUp).Row
        
        With wksData
        .Range("A2:I26").Cut names.Range("G2")
        Application.CutCopyMode = False
      End With
        With wksData
        'Start from cell A1 (1, 1) and assign to the last row and last column
        Set rngDataBlock = .Range(.Cells(1, lLastHTeamCol + 1), .Cells(lLastRow, lLastHTeamCol + 1))
    End With
        x = 60000
        Application.DisplayAlerts = False
        With rngDataBlock
            .AutoFilter Field:=1, Criteria1:=">" & x
            On Error Resume Next
            .Range(Cells(2, lFirstWriteColumn), Cells(lLastRow, lLastHTeamCol + 9)).Delete Shift:=xlUp
        End With
    Application.DisplayAlerts = True
    
    With names
    .Range("G2:O26").Cut wksData.Range("A2")
    Application.CutCopyMode = False
    End With

     
    'Turn off the Autofilter safely
    With wksData
        .AutoFilterMode = False
        If .FilterMode = True Then
            .ShowAllData
        End If
    End With

More coming..

 

[cspengel]

The following is more specific & what I would like to see from you, as an example:
1) Take all the names entered on the "Worksheet" (A2:Ix) sheet and check to see if all of those names also have a salary listed on the "Salary" sheet. If any of the names from "Worksheet" are not on the "Salary" sheet, it ends Sub. If all the names are on the salary sheet and there are corresponding salaries for each of those names, a pop up box will appear letting you know how many combinations to expect.

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

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

'Increment Counters
        'Whether the line had duplicates or not, move to the next name in the
        '  rightmost column, if it was ag the last name, go to the first name in that column and
        '  move the name in the column to the left down to the next name (recursive check if THAT
        '  column was already using the last name for remaining columns to the left)
        aryNames(1, lLastColumn) = aryNames(1, lLastColumn) + 1
        If aryNames(1, lLastColumn) > aryNames(2, lLastColumn) Then
            bCarry = True
            lCarryColumn = lLastColumn
            Do While bCarry = True And lCarryColumn > 0
                aryNames(1, lCarryColumn) = 2
                bCarry = False
                lCarryColumn = lCarryColumn - 1
                If lCarryColumn = 0 Then Exit Do
                aryNames(1, lCarryColumn) = aryNames(1, lCarryColumn) + 1
                If aryNames(1, lCarryColumn) > aryNames(2, lCarryColumn) Then bCarry = True
            Loop
        End If
     
        'Check counter values (for debug)
'        Debug.Print lWriteRow,
'        For lPrint = 1 To lLastColumn
'            Debug.Print aryNames(1, lPrint) & ", ";
'        Next
'        Debug.Print
        DoEvents

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

'Copy row names to right so that each copied row can be sorted alphabetically left to right
    '  this will allow the Excel remove duplicate fuction to remove rows that have identical names
    '  in all of their sorted columns.
    lLastRow = Cells(Rows.Count, lFirstWriteColumn).End(xlUp).Row
    Range(Cells(1, lFirstWriteColumn), Cells(lLastRow, lLastWriteColumn)).Copy Destination:=Cells(1, lLastWriteColumn + 2) ''SALARY
    lFirstHSortColumn = lLastWriteColumn + 2
    lLastHSortColumn = Cells(1, Columns.Count).End(xlToLeft).Column
 
    Range(Cells(1, lFirstWriteColumn), Cells(lLastRow, lLastWriteColumn)).Copy Destination:=Cells(1, lLastHSortColumn + 1) ''PROJECTION
    lFirstHSortColumn2 = lLastHSortColumn + 1
    lLastHSortColumn2 = Cells(1, Columns.Count).End(xlToLeft).Column
  
    Range(Cells(1, lFirstWriteColumn), Cells(lLastRow, lLastWriteColumn)).Copy Destination:=Cells(1, lLastHSortColumn2 + 1) ''TEAM
    lFirstHTeamCol = lLastHSortColumn2 + 1
    lLastHTeamCol = Cells(1, Columns.Count).End(xlToLeft).Column

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

'Assumes the 'Salary' worksheet has names in the column A and salaries in column B starting in row 2
    'Replace HSort names with salary
    With Worksheets("Salary") '''' SALARY
        lLastSalaryRow = .Cells(.Rows.Count, 1).End(xlUp).Row
    End With
    Set rngReplace = Range(Cells(2, lFirstHSortColumn), Cells(lLastRow, lLastHSortColumn))
    For lRowIndex = 2 To lLastSalaryRow
        rngReplace.Replace What:=Worksheets("Salary").Cells(lRowIndex, 1).Value, _
            Replacement:=Worksheets("Salary").Cells(lRowIndex, 2).Value, LookAt:=xlWhole, _
            SearchOrder:=xlByRows, MatchCase:=False, SearchFormat:=False, _
            ReplaceFormat:=False
     Next
     lLastRowDeDuped = Cells(Rows.Count, lFirstWriteColumn).End(xlUp).Row
     'Add Sum Column
   Cells(1, lLastHTeamCol + 1).Value = ChrW(931) & " Salary"
    With Range(Cells(2, lLastHTeamCol + 1), Cells(lLastRowDeDuped, lLastHTeamCol + 1))
        .FormulaR1C1 = "=SUM(RC" & lFirstHSortColumn & ":RC" & lLastHSortColumn & ")"
        Application.Calculate
        .Value = .Value
        End With
     
   lLastRow = Cells(Rows.Count, lFirstWriteColumn).End(xlUp).Row
     
        With wksData
        .Range("A2:I26").Cut names.Range("G2")
        Application.CutCopyMode = False
      End With
        With wksData
        'Start from cell A1 (1, 1) and assign to the last row and last column
        Set rngDataBlock = .Range(.Cells(1, lLastHTeamCol + 1), .Cells(lLastRow, lLastHTeamCol + 1))
    End With
        x = 60000
        Application.DisplayAlerts = False
        With rngDataBlock
            .AutoFilter Field:=1, Criteria1:=">" & x
            On Error Resume Next
            .Range(Cells(2, lFirstWriteColumn), Cells(lLastRow, lLastHTeamCol + 9)).Delete Shift:=xlUp
        End With
    Application.DisplayAlerts = True
 
    With names
    .Range("G2:O26").Cut wksData.Range("A2")
    Application.CutCopyMode = False
    End With

  
    'Turn off the Autofilter safely
    With wksData
        .AutoFilterMode = False
        If .FilterMode = True Then
            .ShowAllData
        End If
    End With

More coming..

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

'Check for duplicate rows in HSort Columns
    '  Can only happen if names are duplicated within an input column
    '  Build aryDeDupe  -- Array(1, 2, 3,...n)  -- to exclude iteration # column

    lLastRow = Cells(Rows.Count, lFirstWriteColumn).End(xlUp).Row
    ReDim aryDeDupe(0 To lLastHSortColumn - lFirstHSortColumn)
    lIndex = 0
    For lColumnIndex = lFirstHSortColumn To lLastHSortColumn
        aryDeDupe(lIndex) = CInt(lColumnIndex - lFirstWriteColumn + 1)
        lIndex = lIndex + 1
    Next
    ActiveSheet.Cells(1, lFirstWriteColumn).CurrentRegion.RemoveDuplicates Columns:=(aryDeDupe), Header:=xlYes
    'Above line won't work unless there are parens around the Columns argument ?????
  
    lLastRowDeDuped = Cells(Rows.Count, lFirstWriteColumn).End(xlUp).Row

7) The names copied over to AD:AL are replaced with the corresponding players projection on the "Salary" sheet. The names copied over to AM:AU are replaced with the corresponding players team located on the "Salary" Sheet. A projection column is added to column AW. The projections from columns AD:AL are calculated(summed) and entered into column AW. A "Stack" column is added to column AX and the most used team in the combinations are calculated using the MODE function. A "Stack POS" column is added to column AY. The players position - who consisted of the most used team are added to column AY by pulling the column headers associated to the corresponding player using the TEXTJOIN function. A "" Stack2" column is added to the AZ column and a "Stack2 POS" column is added to the BA column - Both using the similar method as first stack column.

'''''''''''''''''''''''''''''''''''''PROJECTION
     With Worksheets("Salary")
        lLastSalaryRow = .Cells(.Rows.Count, 1).End(xlUp).Row
    End With
    Set rngReplace = Range(Cells(2, lFirstHSortColumn2), Cells(lLastRow, lLastHSortColumn2))
    For lRowIndex2 = 2 To lLastSalaryRow
        rngReplace.Replace What:=Worksheets("Salary").Cells(lRowIndex2, 1).Value, _
            Replacement:=Worksheets("Salary").Cells(lRowIndex2, 3).Value, LookAt:=xlWhole, _
            SearchOrder:=xlByRows, MatchCase:=False, SearchFormat:=False, _
            ReplaceFormat:=False
    Next '''''''''''''''''''''''''''
  
         '''''''''''''''''''''''''''''''''''''TEAM
     With Worksheets("Salary")
        lLastSalaryRow = .Cells(.Rows.Count, 1).End(xlUp).Row
    End With
    Set rngReplace = Range(Cells(2, lFirstHTeamCol), Cells(lLastRow, lLastHTeamCol))
    For lRowIndex2 = 2 To lLastSalaryRow
        rngReplace.Replace What:=Worksheets("Salary").Cells(lRowIndex2, 1).Value, _
            Replacement:=Worksheets("Salary").Cells(lRowIndex2, 4).Value, LookAt:=xlWhole, _
            SearchOrder:=xlByRows, MatchCase:=False, SearchFormat:=False, _
            ReplaceFormat:=False
    Next '''''''''''''''''''''''''''
  
  
    ''Add Projection Column
    Cells(1, lLastHTeamCol + 2).Value = ChrW(931) & " Projection"
    With Range(Cells(2, lLastHTeamCol + 2), Cells(lLastRowDeDuped, lLastHTeamCol + 2))
        .FormulaR1C1 = "=SUM(RC" & lFirstHSortColumn2 & ":RC" & lLastHSortColumn2 & ")"
        Application.Calculate
        .Value = .Value
    End With
  
     ''Add Team Stack Column
    Cells(1, lLastHTeamCol + 3).Value = ChrW(931) & " Stack"
    With Range(Cells(2, lLastHTeamCol + 3), Cells(lLastRowDeDuped, lLastHTeamCol + 3))
        .FormulaR1C1 = "=INDEX(RC" & lFirstHTeamCol & ":RC" & lLastHTeamCol & ",MODE(MATCH(RC" & lFirstHTeamCol & ":RC" & lLastHTeamCol & ",RC" & lFirstHTeamCol & ":RC" & lLastHTeamCol & ",0)))"
        Application.Calculate
        .Value = .Value
    End With
  
    ''Add Team Stack Pos
    Cells(1, lLastHTeamCol + 4).Value = ChrW(931) & " Stack POS"
    With Range(Cells(2, lLastHTeamCol + 4), Cells(lLastRowDeDuped, lLastHTeamCol + 4))
  
    .Formula2R1C1 = "=TEXTJOIN("","",1,IF(RC[-12]:RC[-4]=RC[-1],R1C[-12]:R1C[-4],""""))"
        Application.Calculate
        .Value = .Value
    End With
  
    ''Add 2nd Team Stack Column
    Cells(1, lLastHTeamCol + 5).Value = ChrW(931) & " Stack2"
    With Range(Cells(2, lLastHTeamCol + 5), Cells(lLastRowDeDuped, lLastHTeamCol + 5))
        .Formula2R1C1 = "=IFERROR(INDEX(RC[-13]:RC[-5],MODE(IF((RC[-13]:RC[-5]<>"""")*(RC[-13]:RC[-5]<>INDEX(RC[-13]:RC[-5],MODE(IF(RC[-13]:RC[-5]<>"""",MATCH(RC[-13]:RC[-5],RC[-13]:RC[-5],0))))),MATCH(RC[-13]:RC[-5],RC[-13]:RC[-5],0)))),"""")"
        Application.Calculate
        .Value = .Value
    End With
  
    ''Add 2nd Team Stack Pos
    Cells(1, lLastHTeamCol + 6).Value = ChrW(931) & " Stack2 POS"
    With Range(Cells(2, lLastHTeamCol + 6), Cells(lLastRowDeDuped, lLastHTeamCol + 6))
  
    .Formula2R1C1 = "=TEXTJOIN("","",1,IF(RC[-12]:RC[-4]=RC[-1],R1C[-12]:R1C[-4],""""))"
        Application.Calculate
        .Value = .Value
    End With

8) "Filter" column added to column BB, "Player1" column added to column BC, "Player2" column added to column BD. Nothing is calculated in these columns. Only Headers added. Currently not a used function for this project.

'Filter 0-1
    Cells(1, lLastHTeamCol + 7).Value = ChrW(931) & " Filter"
    With Range(Cells(2, lLastHTeamCol + 7), Cells(lLastRowDeDuped, lLastHTeamCol + 7))
  
    End With
  
    'Player 1 Filter
    Cells(1, lLastHTeamCol + 8).Value = ChrW(931) & " Player1"
    With Range(Cells(2, lLastHTeamCol + 8), Cells(lLastRowDeDuped, lLastHTeamCol + 8))
  
    End With
  
    'Player 2 Filter
    Cells(1, lLastHTeamCol + 9).Value = ChrW(931) & " Player2"
    With Range(Cells(2, lLastHTeamCol + 9), Cells(lLastRowDeDuped, lLastHTeamCol + 9))
  
    End With

9) Removes all helper columns - U:AU. "Salary" column becomes column U. "Projection" column becomes column V. "Stack" column becomes column W. "Stack POS" column becomes column X. "Stack 2" column becomes column Y. "Stack 2 POS" column becomes column Z. Filter column becomes column AA. "Player1" Column becomes column AB. "Player2" column becomes column AC.. A Dialogue Box then pops open and provides combination info: Possible combinations, unique combinations, duplicates removed, and the time to process. Data is then autofitted to the used range and printed to the "Worksheet" . OptimizeCode_End is then called, which is just turning back on screen updating and whatnot.

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

'Remove Salary Columns
    Range(Cells(2, lFirstHSortColumn), Cells(lLastRowDeDuped, lLastHTeamCol)).EntireColumn.Delete

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