All Combinations of Multiple Columns Without Duplicates

S

Sethnick

New Member
Joined
Aug 6, 2019
Messages
8
I have been searching for a code that does what I am hopeful is understandable to whomever may be able to help me with this. I have multiple columns with multiple names (10 columns in this case), some names are duplicated, and need to generate all possible combinations of these 10 columns of names without the same name appearing twice in any generated row. Here is an example of the output I need with the ability to have a header row as shown (header row will have titles instead of the listed numbers and do not really matter to the output)., I may be confusing this with permutations. I am not sure.

[TABLE="width: 1344"]
<tbody>[TR]
[TD="class: xl63, width: 64"]1[/TD]
[TD="class: xl63, width: 64"]2[/TD]
[TD="class: xl63, width: 64"]3[/TD]
[TD="class: xl63, width: 64"]4[/TD]
[TD="class: xl63, width: 64"]5[/TD]
[TD="class: xl63, width: 64"]6[/TD]
[TD="class: xl63, width: 64"]7[/TD]
[TD="class: xl63, width: 64"]8[/TD]
[TD="class: xl63, width: 64"]9[/TD]
[TD="class: xl63, width: 64"]10[/TD]
[TD="class: xl63, width: 64"][/TD]
[TD="class: xl63, width: 64"]1[/TD]
[TD="class: xl63, width: 64"]2[/TD]
[TD="class: xl63, width: 64"]3[/TD]
[TD="class: xl63, width: 64"]4[/TD]
[TD="class: xl63, width: 64"]5[/TD]
[TD="class: xl63, width: 64"]6[/TD]
[TD="class: xl63, width: 64"]7[/TD]
[TD="class: xl63, width: 64"]8[/TD]
[TD="class: xl63, width: 64"]9[/TD]
[TD="class: xl63, width: 64"]10[/TD]
[/TR]
[TR]
[TD="class: xl63"]Joe[/TD]
[TD="class: xl63"]Mike[/TD]
[TD="class: xl63"]Ed[/TD]
[TD="class: xl63"]Linda[/TD]
[TD="class: xl63"]Ed[/TD]
[TD="class: xl63"]Mike[/TD]
[TD="class: xl63"]Don[/TD]
[TD="class: xl63"]Chris[/TD]
[TD="class: xl63"]Kevin[/TD]
[TD="class: xl63"]Chris[/TD]
[TD="class: xl63"][/TD]
[TD="class: xl63"]Joe[/TD]
[TD="class: xl63"]Mike[/TD]
[TD="class: xl63"]Steve[/TD]
[TD="class: xl63"]Linda[/TD]
[TD="class: xl63"]Ed[/TD]
[TD="class: xl63"]Jeff[/TD]
[TD="class: xl63"]Don[/TD]
[TD="class: xl63"]Chris[/TD]
[TD="class: xl63"]Kevin[/TD]
[TD="class: xl63"]Harold[/TD]
[/TR]
[TR]
[TD="class: xl63"]John[/TD]
[TD="class: xl63"]Ed[/TD]
[TD="class: xl63"]Mike[/TD]
[TD="class: xl63"]Maria[/TD]
[TD="class: xl63"]John[/TD]
[TD="class: xl63"]Jeff[/TD]
[TD="class: xl63"]George[/TD]
[TD="class: xl63"]Mike[/TD]
[TD="class: xl63"]Earl[/TD]
[TD="class: xl63"]Ed[/TD]
[TD="class: xl63"][/TD]
[TD="class: xl63"]Joe[/TD]
[TD="class: xl63"]Ed[/TD]
[TD="class: xl63"]Mike[/TD]
[TD="class: xl63"]Linda[/TD]
[TD="class: xl63"]John[/TD]
[TD="class: xl63"]Jeff[/TD]
[TD="class: xl63"]Don[/TD]
[TD="class: xl63"]Chris[/TD]
[TD="class: xl63"]Kevin[/TD]
[TD="class: xl63"]Steve[/TD]
[/TR]
[TR]
[TD="class: xl63"]Steve[/TD]
[TD="class: xl63"]Jack[/TD]
[TD="class: xl63"]Steve[/TD]
[TD="class: xl63"]Jack[/TD]
[TD="class: xl63"]Joe[/TD]
[TD="class: xl63"]Dale[/TD]
[TD="class: xl63"]Jack[/TD]
[TD="class: xl63"]John[/TD]
[TD="class: xl63"]Ed[/TD]
[TD="class: xl63"]Mike[/TD]
[TD="class: xl63"][/TD]
[TD="class: xl63"][/TD]
[TD="class: xl63"][/TD]
[TD="class: xl63"][/TD]
[TD="class: xl63"][/TD]
[TD="class: xl63"][/TD]
[TD="class: xl63"][/TD]
[TD="class: xl63"][/TD]
[TD="class: xl63"][/TD]
[TD="class: xl63"][/TD]
[TD="class: xl63"][/TD]
[/TR]
[TR]
[TD="class: xl63"][/TD]
[TD="class: xl63"][/TD]
[TD="class: xl63"][/TD]
[TD="class: xl63"]Joe[/TD]
[TD="class: xl63"][/TD]
[TD="class: xl63"][/TD]
[TD="class: xl63"][/TD]
[TD="class: xl63"]Ed[/TD]
[TD="class: xl63"]John[/TD]
[TD="class: xl63"]Steve[/TD]
[TD="class: xl63"][/TD]
[TD="class: xl63"][/TD]
[TD="class: xl63"][/TD]
[TD="class: xl63"][/TD]
[TD="class: xl63"][/TD]
[TD="class: xl63"][/TD]
[TD="class: xl63"][/TD]
[TD="class: xl63"][/TD]
[TD="class: xl63"][/TD]
[TD="class: xl63"][/TD]
[TD="class: xl63"][/TD]
[/TR]
[TR]
[TD="class: xl63"][/TD]
[TD="class: xl63"][/TD]
[TD="class: xl63"][/TD]
[TD="class: xl63"][/TD]
[TD="class: xl63"][/TD]
[TD="class: xl63"][/TD]
[TD="class: xl63"][/TD]
[TD="class: xl63"][/TD]
[TD="class: xl63"][/TD]
[TD="class: xl63"]Harold[/TD]
[TD="class: xl63"][/TD]
[TD="class: xl63"][/TD]
[TD="class: xl63"][/TD]
[TD="class: xl63"][/TD]
[TD="class: xl63"][/TD]
[TD="class: xl63"][/TD]
[TD="class: xl63"][/TD]
[TD="class: xl63"][/TD]
[TD="class: xl63"][/TD]
[TD="class: xl63"][/TD]
[TD="class: xl63"][/TD]
[/TR]
</tbody>[/TABLE]


Thank you for any help provided.
 
Sort by date Sort by votes
A bit more code to ensure the salary worksheet contains valid numbers, does not have duplicate names and has a name for each entry in the grid on the main worksheet. Read notes in the code.

Code: 
Sub SalaryValidation()
    'Ensure the names on the Main and Salary worksheets have no leading or
    '  trailing spaces.
    'Ensures each of the names on the main sheet have a single entry on the salary
    '  worksheet and displays the names and the salary range (min to max) on that worksheet.
    'This is needed because there is no way to know that a salary is incorrect
    '  (or missing) from the group totals generated on the main worksheet.  This won't help
    '  if someone enters 44,000 instead of 45,000 but will help if the entry is blank or
    '  way out of line (44 instead of 44,000)
    'It would be worthwhile to put a data validation on column B of the Salary worksheet
    '  that restricted entries to postive numbers within a reasonable salary range.
    
    Dim wksMain As Worksheet
    Set wksMain = Sheets(1)                 'wksMain holds the input grid and output list
    Dim wksSalary As Worksheet
    Set wksSalary = Worksheets("Salary")    'wksSalary holds the 2-Column Salary data
                                            '  (w/Headers: A=Name, B=Salary)
    Dim lLastRow As Long
    Dim lDupe As Long
    Dim sOutput As String
    Dim varMin As Variant
    Dim varMax As Variant
    Dim varSalary As Variant
    
    Dim oSD As Object
    Set oSD = CreateObject("Scripting.Dictionary")
    oSD.CompareMode = vbTextCompare
    
    Dim rngCell As Range
    Dim varK As Variant, varI As Variant, varTemp As Variant, lIndex As Long
    
    'Remove Error worksheets from past runs
    On Error Resume Next
    Application.DisplayAlerts = False
    Worksheets("Duplicate Names").Delete
    Worksheets("Missing Names").Delete
    Worksheets("Bad Salary").Delete
    Application.DisplayAlerts = True
    On Error GoTo 0
    
    'Remove leading/trailing spaces from Names
    With wksMain
        .AutoFilterMode = False
        For Each rngCell In .Range("A1").CurrentRegion.Cells
            rngCell.Value = Trim(rngCell.Value)
        Next
    End With
    With wksSalary
        .AutoFilterMode = False
        lLastRow = .Cells(.Rows.Count, 1).End(xlUp).Row
        For Each rngCell In .Range("A2:A" & lLastRow).Cells
            rngCell.Value = Trim(rngCell.Value)
        Next
    End With
    
    'Check for duplicate names on wksSalary
    '  Inventory non-blank cells in column A on wksSalary
    With wksSalary
        For Each rngCell In .Range("A2:A" & lLastRow).Cells
            If Len(rngCell.Value) > 0 Then
                oSD.Item(rngCell.Value) = oSD.Item(rngCell.Value) + 1
            End If
        Next
    End With
    '  Write Names with multiple entries to manipulable array
    If oSD.Count > 0 Then
        ReDim varTemp(1 To 2, 1 To oSD.Count)
        varK = oSD.keys: varI = oSD.Items
        For lIndex = 1 To oSD.Count
            If varI(lIndex - 1) > 1 Then
                lDupe = lDupe + 1
                varTemp(1, lDupe) = varK(lIndex - 1): varTemp(2, lDupe) = varI(lIndex - 1)
            End If
        Next
        If lDupe > 0 Then
            'Write to Error Worksheet
            AddAndNameSheet ("Duplicate Names")
            Worksheets("Duplicate Names").Range("A1").Resize(oSD.Count, 2).Value = Application.Transpose(varTemp)
            
            MsgBox "There are duplicate names on the " & wksSalary.Name & " worksheet." & vbLf & vbLf & _
                "Correct this problem and rerun the code to validate the correction."
            GoTo End_Sub
        Else
            sOutput = "No Duplicate Names on the " & wksSalary.Name & " worksheet." & vbLf
        End If
    End If
    
    'Verify each name on wksMain has corresponding name on wksSalary
    '  Inventory Names on wksMain
    Set oSD = CreateObject("Scripting.Dictionary")
    oSD.CompareMode = vbTextCompare
    
    For Each rngCell In wksMain.Range("A1").CurrentRegion.Offset(1, 0).Cells
        If Len(rngCell.Value) > 0 Then
            oSD.Item(rngCell.Value) = oSD.Item(rngCell.Value) + 1
        End If
    Next
    '  Remove names that are on wksSalary
    With wksSalary
        For Each rngCell In .Range("A2:A" & lLastRow).Cells
            If oSD.exists(rngCell.Value) Then
                oSD.Remove rngCell.Value
            End If
        Next
    End With
    '  Write to manipulable array
    If oSD.Count > 0 Then
        ReDim varTemp(1 To 2, 1 To oSD.Count)
        varK = oSD.keys: varI = oSD.Items
        For lIndex = 1 To oSD.Count
            varTemp(1, lIndex) = varK(lIndex - 1): varTemp(2, lIndex) = varI(lIndex - 1)
        Next
        'Write to error Worksheet
        AddAndNameSheet ("Missing Names")
        Worksheets("Missing Names").Range("A1").Resize(oSD.Count, 2).Value = Application.Transpose(varTemp)
        MsgBox "The names listed on 'Missing Names' worksheet are in the grid on" & _
            "the " & wksMain.Name & " worksheet but" & _
            "do not have an entry on the " & wksSalary.Name & " worksheet. " & vbLf & vbLf & _
            "Correct this problem and rerun the code to validate the correction."
        GoTo End_Sub
    Else
            sOutput = sOutput & _
            "No Missing Names on the " & wksSalary.Name & " worksheet." & vbLf
    End If
    
    'Verify each entry on wksSalary column A has a non-zero numeric entry in column B
    '  Inventory entries on column A that do not have a positive entry in column B
    Set oSD = CreateObject("Scripting.Dictionary")
    oSD.CompareMode = vbTextCompare
    
    varMin = 1000000
    With wksSalary
        For Each rngCell In .Range("A2:A" & lLastRow).Cells
            If Len(rngCell.Value) > 0 Then
                varSalary = rngCell.Offset(0, 1).Value
                If IsNumeric(varSalary) And varSalary > 0 Then
                    If varSalary > varMax Then varMax = varSalary
                    If varSalary < varMin Then varMin = varSalary
                Else
                    oSD.Item(rngCell.Value) = varSalary
                End If
            End If
        Next
    End With
    If oSD.Count > 0 Then
        ReDim varTemp(1 To 2, 1 To oSD.Count)
        varK = oSD.keys: varI = oSD.Items
        For lIndex = 1 To oSD.Count
            varTemp(1, lIndex) = varK(lIndex - 1): varTemp(2, lIndex) = varI(lIndex - 1)
        Next
        'Write to error Worksheet
        AddAndNameSheet ("Bad Salary")
        Worksheets("Bad Salary").Range("A1").Resize(oSD.Count, 2).Value = Application.Transpose(varTemp)
        MsgBox "The names listed on 'Bad Salary' worksheet do not have a positive entry on the " & _
            wksSalary.Name & " worksheet. " & vbLf & vbLf & _
            "Correct this problem and rerun the code to validate the correction."
        GoTo End_Sub
    Else
            sOutput = sOutput & _
            "All Names on the " & wksSalary.Name & " worksheet have entries ranging " & vbLf & _
                "     from " & varMin & " to " & varMax & "."
    End If
    
    
    MsgBox sOutput
    
End_Sub:
    
End Sub


Sub AddAndNameSheet(sWorksheet As String)
    'Delete worksheet sWorksheet if it exists, create new worksheet with same name after last sheet
    '  No worksheet name validity check done on sName
    On Error Resume Next
    Application.DisplayAlerts = False
    Worksheets(sWorksheet).Delete
    Application.DisplayAlerts = True
    On Error GoTo 0
    Worksheets.Add(After:=Sheets(Sheets.Count)).Name = sWorksheet 'After last
End Sub
 
Upvote 0

Excel Facts

Excel Joke
Why can't spreadsheets drive cars? They crash too often!
This code is awesome. The only question I have is: How can I limit the number of rows being compared? For example, say I want to compare Names in 5 columns but only compare the first three rows. And then do it again comparing the next 3 rows, etc.
 
Upvote 0
visionquest1972 said:
This code is awesome. The only question I have is: How can I limit the number of rows being compared? For example, say I want to compare Names in 5 columns but only compare the first three rows. And then do it again comparing the next 3 rows, etc.
Click to expand...
The size of of the Salary and Main worksheet data blocks are not hard coded. If you setup the sheets using your data, it should work. If it does not, please provide samples of your inputs and desired outputs.
 
Upvote 0
pbornemeier said:
The size of of the Salary and Main worksheet data blocks are not hard coded. If you setup the sheets using your data, it should work. If it does not, please provide samples of your inputs and desired outputs.
Click to expand...
The macro works great. Thank you for your reply. My data set is different from the data set used in this post. My data set is basically the same concept with different criteria applied. I will include a mini-sheet with this post but I am also going to post a link that you can visit.
The link is a Google Sheet that has a "README" tab that explains what my data set is and the results desired from the macro loop. It also contains tabs that show a typical data set I will be working with and an example data set that demonstrates the functionally of the macro desired (the link is named "My Name Combos Data Set Link" below):

My Name Combos Data Set Link

Thank you SO SO SO much for your help. Your code is awesome and is the perfect solution for my problem.

Here is the Mini-Sheet (example of the data set I will use. This is the starting point for the macro. It is not a result set)

Name_Combos_Problem (Jason McCoy).xlsb
ABCDEFGHIJKLMNOPQRSTUVWXYZAA
1QB NAMEQB COSTQB FPTSRB1 NAMERB1 COSTRB1 FPTSRB2 NAMERB2 COSTRB2 FPTSWR1 NAMEWR1 COSTWR1 FPTSWR2 NAMEWR2 COSTWR2 FPTSWR3 NAMEWR3 COSTWR3 FPTSTE NAMETE COSTTE FPTSFLEX NAMEFLEX COSTFLEX FPTSDEFENSE NAMEDEFENSE COSTDEFENSE FPTS
2Josh Allen (BUF)$7,00040.22Ezekiel Elliott (DAL)$6,60031.2Ezekiel Elliott (DAL)$6,60031.2Mike Williams (LAC)$6,40036.2Mike Williams (LAC)$6,40036.2Mike Williams (LAC)$6,40036.2Dalton Schultz (DAL)$3,30026Mike Williams$6,40036.2Arizona Cardinals (ARI)$3,10020
3Justin Herbert (LAC)$6,40032.52Kareem Hunt (CLE)$5,60027.5Kareem Hunt (CLE)$5,60027.5Cooper Kupp (LAR)$8,30034.2Cooper Kupp (LAR)$8,30034.2Cooper Kupp (LAR)$8,30034.2Tyler Conklin (MIN)$8,20020.4Davante Adams$8,30034.2New Orleans Saints (NO)$4,30019
4Matthew Stafford (LAR)$6,80031.68Peyton Barber (LV)$6,40026.6Peyton Barber (LV)$6,40026.6Emmanuel Sanders (BUF)$6,80030.6Emmanuel Sanders (BUF)$6,80030.6Emmanuel Sanders (BUF)$6,80030.6Zach Ertz (PHI)$2,90020Najee Harris$6,60031.2Denver Broncos (DEN)$3,00018
5Tom Brady (TB)$6,50030.84James Robinson (JAC)$4,30026.2James Robinson (JAC)$4,30026.2Davante Adams (GB)$7,20029.8Davante Adams (GB)$7,20029.8Davante Adams (GB)$7,20029.8Mark Andrews (BAL)$5,00018.9Cooper Kupp$6,80030.6Cleveland Browns (CLE)$3,20016
6Sam Darnold (CAR)$5,90028.26Alvin Kamara (NO)$6,00026.1Alvin Kamara (NO)$6,00026.1Ja'Marr Chase (CIN)$4,20026.4Ja'Marr Chase (CIN)$4,20026.4Ja'Marr Chase (CIN)$4,20026.4Dawson Knox (BUF)$3,80018.6Justin Jefferson$7,20029.8Dallas Cowboys (DAL)$3,20012
7Kirk Cousins (MIN)$6,30028.12James Conner (ARI)$5,70025.4James Conner (ARI)$5,70025.4DeSean Jackson (LAR)$7,30025.7DeSean Jackson (LAR)$7,30025.7DeSean Jackson (LAR)$7,30025.7Travis Kelce (KC)$6,20017.1Kareem Hunt$5,60027.5Cincinnati Bengals (CIN)$2,10012
8Patrick Mahomes II (KC)$6,80025.54Alexander Mattison (MIN)$5,80023.7Alexander Mattison (MIN)$5,80023.7Justin Jefferson (MIN)$3,00024Justin Jefferson (MIN)$3,00024Justin Jefferson (MIN)$3,00024George Kittle (SF)$3,40015.3Ezekiel Elliott$6,40026.6Los Angeles Chargers (LAC)$2,70010
9Ryan Tannehill (TEN)$5,90025.24Austin Ekeler (LAC)$7,20022.7Austin Ekeler (LAC)$7,20022.7D.K. Metcalf (SEA)$6,20023.7D.K. Metcalf (SEA)$6,20023.7D.K. Metcalf (SEA)$6,20023.7Tyler Higbee (LAR)$4,00015Emmanuel Sanders$4,20026.4Miami Dolphins (MIA)$2,30010
10Jalen Hurts (PHI)$8,20024.9D'Andre Swift (DET)$8,60022.4D'Andre Swift (DET)$8,60022.4Kendrick Bourne (NE)$5,90023.5Kendrick Bourne (NE)$5,90023.5Kendrick Bourne (NE)$5,90023.5Tommy Tremble (CAR)$3,40014.9Peyton Barber$4,30026.2Jacksonville Jaguars (JAC)$3,3008
11Taylor Heinicke (WAS)$6,20023.48Derrick Henry (TEN)$6,50021.4Derrick Henry (TEN)$6,50021.4Hunter Renfrow (LV)$5,40022.5Hunter Renfrow (LV)$5,40022.5Hunter Renfrow (LV)$5,40022.5Mike Gesicki (MIA)$4,70013.2Alexander Mattison$6,00026.1Philadelphia Eagles (PHI)$2,9008
12Derek Carr (LV)$5,60023.38Antonio Gibson (WAS)$4,80020.9Antonio Gibson (WAS)$4,80020.9Chris Godwin (TB)$6,30021.6Chris Godwin (TB)$6,30021.6Chris Godwin (TB)$6,30021.6Pat Freiermuth (PIT)$3,00011.2Dalton Schultz$3,30026Carolina Panthers (CAR)$3,8007
13Lamar Jackson (BAL)$8,30022.54Aaron Jones (GB)$8,20020.8Aaron Jones (GB)$8,20020.8D.J. Moore (CAR)$3,40021.6D.J. Moore (CAR)$3,40021.6D.J. Moore (CAR)$3,40021.6Logan Thomas (WAS)$2,50010.7DK Metcalf$7,30025.7Buffalo Bills (BUF)$3,1007
14Jacoby Brissett (MIA)$6,90021.12Saquon Barkley (NYG)$4,20020.1Saquon Barkley (NYG)$4,20020.1Marquez Valdes-Scantling (GB)$4,80020.8Marquez Valdes-Scantling (GB)$4,80020.8Marquez Valdes-Scantling (GB)$4,80020.8Austin Hooper (CLE)$7,40010.4James Robinson$5,70025.4Detroit Lions (DET)$2,7007
15Dak Prescott (DAL)$4,90020.3Zack Moss (BUF)$4,60018.9Zack Moss (BUF)$4,60018.9Brandin Cooks (HOU)$5,40020.4Brandin Cooks (HOU)$5,40020.4Brandin Cooks (HOU)$5,40020.4Lee Smith (ATL)$3,00010.4DeSean Jackson$3,00024Green Bay Packers (GB)$2,0007
16Kyler Murray (ARI)$7,80020.28Clyde Edwards-Helaire (KC)$5,00018.3Clyde Edwards-Helaire (KC)$5,00018.3A.J. Green (ARI)$6,10019.6A.J. Green (ARI)$6,10019.6A.J. Green (ARI)$6,10019.6Dallas Goedert (PHI)$3,6009.9Brandin Cooks$6,20023.7Indianapolis Colts (IND)$2,0007
17Joe Burrow (CIN)$6,70019.04Melvin Gordon III (DEN)$4,70018.1Melvin Gordon III (DEN)$4,70018.1Keenan Allen (LAC)$4,50019.2Keenan Allen (LAC)$4,50019.2Keenan Allen (LAC)$4,50019.2Rob Gronkowski (TB)$2,5009.7D'Andre Swift$5,80023.7New York Giants (NYG)$3,3006
18Aaron Rodgers (GB)$5,50018.58Najee Harris (PIT)$7,80017.6Najee Harris (PIT)$7,80017.6Adam Thielen (MIN)$6,60019Adam Thielen (MIN)$6,60019Adam Thielen (MIN)$6,60019Darren Waller (LV)$5,5009.5DJ Moore$5,90023.5Chicago Bears (CHI)$3,0005
19Baker Mayfield (CLE)$5,70018.22Chris Carson (SEA)$5,90017.4Chris Carson (SEA)$5,90017.4D.J. Chark Jr. (JAC)$4,00018.7D.J. Chark Jr. (JAC)$4,00018.7D.J. Chark Jr. (JAC)$4,00018.7Gerald Everett (SEA)$2,5008.7Austin Ekeler$7,20022.7Atlanta Falcons (ATL)$2,5005
20Russell Wilson (SEA)$6,00016.94Nyheim Hines (IND)$6,40016.2Nyheim Hines (IND)$6,40016.2Mike Evans (TB)$5,80018.6Mike Evans (TB)$5,80018.6Mike Evans (TB)$5,80018.6Will Dissly (SEA)$5,1008.6JaMarr Chase$5,40022.5New York Jets (NYJ)$2,2004
FULL_DATA_SET


Thank You,
Jason
 
Upvote 0
visionquest1972 said:
The macro works great. Thank you for your reply. My data set is different from the data set used in this post. My data set is basically the same concept with different criteria applied. I will include a mini-sheet with this post but I am also going to post a link that you can visit.
The link is a Google Sheet that has a "README" tab that explains what my data set is and the results desired from the macro loop. It also contains tabs that show a typical data set I will be working with and an example data set that demonstrates the functionally of the macro desired (the link is named "My Name Combos Data Set Link" below):

My Name Combos Data Set Link

Thank you SO SO SO much for your help. Your code is awesome and is the perfect solution for my problem.

Here is the Mini-Sheet (example of the data set I will use. This is the starting point for the macro. It is not a result set)

Name_Combos_Problem (Jason McCoy).xlsb
ABCDEFGHIJKLMNOPQRSTUVWXYZAA
1QB NAMEQB COSTQB FPTSRB1 NAMERB1 COSTRB1 FPTSRB2 NAMERB2 COSTRB2 FPTSWR1 NAMEWR1 COSTWR1 FPTSWR2 NAMEWR2 COSTWR2 FPTSWR3 NAMEWR3 COSTWR3 FPTSTE NAMETE COSTTE FPTSFLEX NAMEFLEX COSTFLEX FPTSDEFENSE NAMEDEFENSE COSTDEFENSE FPTS
2Josh Allen (BUF)$7,00040.22Ezekiel Elliott (DAL)$6,60031.2Ezekiel Elliott (DAL)$6,60031.2Mike Williams (LAC)$6,40036.2Mike Williams (LAC)$6,40036.2Mike Williams (LAC)$6,40036.2Dalton Schultz (DAL)$3,30026Mike Williams$6,40036.2Arizona Cardinals (ARI)$3,10020
3Justin Herbert (LAC)$6,40032.52Kareem Hunt (CLE)$5,60027.5Kareem Hunt (CLE)$5,60027.5Cooper Kupp (LAR)$8,30034.2Cooper Kupp (LAR)$8,30034.2Cooper Kupp (LAR)$8,30034.2Tyler Conklin (MIN)$8,20020.4Davante Adams$8,30034.2New Orleans Saints (NO)$4,30019
4Matthew Stafford (LAR)$6,80031.68Peyton Barber (LV)$6,40026.6Peyton Barber (LV)$6,40026.6Emmanuel Sanders (BUF)$6,80030.6Emmanuel Sanders (BUF)$6,80030.6Emmanuel Sanders (BUF)$6,80030.6Zach Ertz (PHI)$2,90020Najee Harris$6,60031.2Denver Broncos (DEN)$3,00018
5Tom Brady (TB)$6,50030.84James Robinson (JAC)$4,30026.2James Robinson (JAC)$4,30026.2Davante Adams (GB)$7,20029.8Davante Adams (GB)$7,20029.8Davante Adams (GB)$7,20029.8Mark Andrews (BAL)$5,00018.9Cooper Kupp$6,80030.6Cleveland Browns (CLE)$3,20016
6Sam Darnold (CAR)$5,90028.26Alvin Kamara (NO)$6,00026.1Alvin Kamara (NO)$6,00026.1Ja'Marr Chase (CIN)$4,20026.4Ja'Marr Chase (CIN)$4,20026.4Ja'Marr Chase (CIN)$4,20026.4Dawson Knox (BUF)$3,80018.6Justin Jefferson$7,20029.8Dallas Cowboys (DAL)$3,20012
7Kirk Cousins (MIN)$6,30028.12James Conner (ARI)$5,70025.4James Conner (ARI)$5,70025.4DeSean Jackson (LAR)$7,30025.7DeSean Jackson (LAR)$7,30025.7DeSean Jackson (LAR)$7,30025.7Travis Kelce (KC)$6,20017.1Kareem Hunt$5,60027.5Cincinnati Bengals (CIN)$2,10012
8Patrick Mahomes II (KC)$6,80025.54Alexander Mattison (MIN)$5,80023.7Alexander Mattison (MIN)$5,80023.7Justin Jefferson (MIN)$3,00024Justin Jefferson (MIN)$3,00024Justin Jefferson (MIN)$3,00024George Kittle (SF)$3,40015.3Ezekiel Elliott$6,40026.6Los Angeles Chargers (LAC)$2,70010
9Ryan Tannehill (TEN)$5,90025.24Austin Ekeler (LAC)$7,20022.7Austin Ekeler (LAC)$7,20022.7D.K. Metcalf (SEA)$6,20023.7D.K. Metcalf (SEA)$6,20023.7D.K. Metcalf (SEA)$6,20023.7Tyler Higbee (LAR)$4,00015Emmanuel Sanders$4,20026.4Miami Dolphins (MIA)$2,30010
10Jalen Hurts (PHI)$8,20024.9D'Andre Swift (DET)$8,60022.4D'Andre Swift (DET)$8,60022.4Kendrick Bourne (NE)$5,90023.5Kendrick Bourne (NE)$5,90023.5Kendrick Bourne (NE)$5,90023.5Tommy Tremble (CAR)$3,40014.9Peyton Barber$4,30026.2Jacksonville Jaguars (JAC)$3,3008
11Taylor Heinicke (WAS)$6,20023.48Derrick Henry (TEN)$6,50021.4Derrick Henry (TEN)$6,50021.4Hunter Renfrow (LV)$5,40022.5Hunter Renfrow (LV)$5,40022.5Hunter Renfrow (LV)$5,40022.5Mike Gesicki (MIA)$4,70013.2Alexander Mattison$6,00026.1Philadelphia Eagles (PHI)$2,9008
12Derek Carr (LV)$5,60023.38Antonio Gibson (WAS)$4,80020.9Antonio Gibson (WAS)$4,80020.9Chris Godwin (TB)$6,30021.6Chris Godwin (TB)$6,30021.6Chris Godwin (TB)$6,30021.6Pat Freiermuth (PIT)$3,00011.2Dalton Schultz$3,30026Carolina Panthers (CAR)$3,8007
13Lamar Jackson (BAL)$8,30022.54Aaron Jones (GB)$8,20020.8Aaron Jones (GB)$8,20020.8D.J. Moore (CAR)$3,40021.6D.J. Moore (CAR)$3,40021.6D.J. Moore (CAR)$3,40021.6Logan Thomas (WAS)$2,50010.7DK Metcalf$7,30025.7Buffalo Bills (BUF)$3,1007
14Jacoby Brissett (MIA)$6,90021.12Saquon Barkley (NYG)$4,20020.1Saquon Barkley (NYG)$4,20020.1Marquez Valdes-Scantling (GB)$4,80020.8Marquez Valdes-Scantling (GB)$4,80020.8Marquez Valdes-Scantling (GB)$4,80020.8Austin Hooper (CLE)$7,40010.4James Robinson$5,70025.4Detroit Lions (DET)$2,7007
15Dak Prescott (DAL)$4,90020.3Zack Moss (BUF)$4,60018.9Zack Moss (BUF)$4,60018.9Brandin Cooks (HOU)$5,40020.4Brandin Cooks (HOU)$5,40020.4Brandin Cooks (HOU)$5,40020.4Lee Smith (ATL)$3,00010.4DeSean Jackson$3,00024Green Bay Packers (GB)$2,0007
16Kyler Murray (ARI)$7,80020.28Clyde Edwards-Helaire (KC)$5,00018.3Clyde Edwards-Helaire (KC)$5,00018.3A.J. Green (ARI)$6,10019.6A.J. Green (ARI)$6,10019.6A.J. Green (ARI)$6,10019.6Dallas Goedert (PHI)$3,6009.9Brandin Cooks$6,20023.7Indianapolis Colts (IND)$2,0007
17Joe Burrow (CIN)$6,70019.04Melvin Gordon III (DEN)$4,70018.1Melvin Gordon III (DEN)$4,70018.1Keenan Allen (LAC)$4,50019.2Keenan Allen (LAC)$4,50019.2Keenan Allen (LAC)$4,50019.2Rob Gronkowski (TB)$2,5009.7D'Andre Swift$5,80023.7New York Giants (NYG)$3,3006
18Aaron Rodgers (GB)$5,50018.58Najee Harris (PIT)$7,80017.6Najee Harris (PIT)$7,80017.6Adam Thielen (MIN)$6,60019Adam Thielen (MIN)$6,60019Adam Thielen (MIN)$6,60019Darren Waller (LV)$5,5009.5DJ Moore$5,90023.5Chicago Bears (CHI)$3,0005
19Baker Mayfield (CLE)$5,70018.22Chris Carson (SEA)$5,90017.4Chris Carson (SEA)$5,90017.4D.J. Chark Jr. (JAC)$4,00018.7D.J. Chark Jr. (JAC)$4,00018.7D.J. Chark Jr. (JAC)$4,00018.7Gerald Everett (SEA)$2,5008.7Austin Ekeler$7,20022.7Atlanta Falcons (ATL)$2,5005
20Russell Wilson (SEA)$6,00016.94Nyheim Hines (IND)$6,40016.2Nyheim Hines (IND)$6,40016.2Mike Evans (TB)$5,80018.6Mike Evans (TB)$5,80018.6Mike Evans (TB)$5,80018.6Will Dissly (SEA)$5,1008.6JaMarr Chase$5,40022.5New York Jets (NYJ)$2,2004
FULL_DATA_SET


Thank You,
Jason
Click to expand...
And here is a Mini-Sheet with the desired result set:

Name_Combos_Problem (Jason McCoy).xlsb
ABCDEFGHIJKLMNOPQRSTUVWXYZAAABAC
1QB NAMEQB COSTQB FPTSRB1 NAMERB1 COSTRB1 FPTSRB2 NAMERB2 COSTRB2 FPTSWR1 NAMEWR1 COSTWR1 FPTSWR2 NAMEWR2 COSTWR2 FPTSWR3 NAMEWR3 COSTWR3 FPTSTE NAMETE COSTTE FPTSFLEX NAMEFLEX COSTFLEX FPTSDEFENSE NAMEDEFENSE COSTDEFENSE FPTSTOTAL COSTTOTAL FPTS
2Justin Herbert (LAC)$6,40032.52Peyton Barber (LV)$6,40026.6James Robinson (JAC)$4,30026.2Emmanuel Sanders (BUF)$6,80030.6Davante Adams (GB)$7,20029.8Ja'Marr Chase (CIN)$4,20026.4Zach Ertz (PHI)$2,90020Derrick Henry$8,60022.4Denver Broncos (DEN)$3,0001849800232.52
3Sam Darnold (CAR)$5,90028.26Peyton Barber (LV)$6,40026.6James Robinson (JAC)$4,30026.2Emmanuel Sanders (BUF)$6,80030.6Davante Adams (GB)$7,20029.8Ja'Marr Chase (CIN)$4,20026.4Zach Ertz (PHI)$2,90020Derrick Henry$8,60022.4Denver Broncos (DEN)$3,0001849300228.26
4Kirk Cousins (MIN)$6,30028.12Peyton Barber (LV)$6,40026.6James Robinson (JAC)$4,30026.2Emmanuel Sanders (BUF)$6,80030.6Davante Adams (GB)$7,20029.8Ja'Marr Chase (CIN)$4,20026.4Zach Ertz (PHI)$2,90020Derrick Henry$8,60022.4Denver Broncos (DEN)$3,0001849700228.12
5Ryan Tannehill (TEN)$5,90025.24Peyton Barber (LV)$6,40026.6James Robinson (JAC)$4,30026.2Emmanuel Sanders (BUF)$6,80030.6Davante Adams (GB)$7,20029.8Ja'Marr Chase (CIN)$4,20026.4Zach Ertz (PHI)$2,90020Derrick Henry$8,60022.4Denver Broncos (DEN)$3,0001849300225.24
6Taylor Heinicke (WAS)$6,20023.48Peyton Barber (LV)$6,40026.6James Robinson (JAC)$4,30026.2Emmanuel Sanders (BUF)$6,80030.6Davante Adams (GB)$7,20029.8Ja'Marr Chase (CIN)$4,20026.4Zach Ertz (PHI)$2,90020Derrick Henry$8,60022.4Denver Broncos (DEN)$3,0001849600223.48
7Derek Carr (LV)$5,60023.38Peyton Barber (LV)$6,40026.6James Robinson (JAC)$4,30026.2Emmanuel Sanders (BUF)$6,80030.6Davante Adams (GB)$7,20029.8Ja'Marr Chase (CIN)$4,20026.4Zach Ertz (PHI)$2,90020Derrick Henry$8,60022.4Denver Broncos (DEN)$3,0001849000223.38
8Justin Herbert (LAC)$6,40032.52James Robinson (JAC)$4,30026.2Alvin Kamara (NO)$6,00026.1Davante Adams (GB)$7,20029.8Ja'Marr Chase (CIN)$4,20026.4DeSean Jackson (LAR)$7,30025.7Mark Andrews (BAL)$5,00018.9Mike Evans$6,30021.6Cleveland Browns (CLE)$3,2001649900223.22
9Dak Prescott (DAL)$4,90020.3Peyton Barber (LV)$6,40026.6James Robinson (JAC)$4,30026.2Emmanuel Sanders (BUF)$6,80030.6Davante Adams (GB)$7,20029.8Ja'Marr Chase (CIN)$4,20026.4Zach Ertz (PHI)$2,90020Derrick Henry$8,60022.4Denver Broncos (DEN)$3,0001848300220.3
10Josh Allen (BUF)$7,00040.22Alvin Kamara (NO)$6,00026.1James Conner (ARI)$5,70025.4Ja'Marr Chase (CIN)$4,20026.4DeSean Jackson (LAR)$7,30025.7Justin Jefferson (MIN)$3,00024Dawson Knox (BUF)$3,80018.6Kendrick Bourne$3,40021.6Dallas Cowboys (DAL)$3,2001243600220.02
11Sam Darnold (CAR)$5,90028.26James Robinson (JAC)$4,30026.2Alvin Kamara (NO)$6,00026.1Davante Adams (GB)$7,20029.8Ja'Marr Chase (CIN)$4,20026.4DeSean Jackson (LAR)$7,30025.7Mark Andrews (BAL)$5,00018.9Mike Evans$6,30021.6Cleveland Browns (CLE)$3,2001649400218.96
12Kirk Cousins (MIN)$6,30028.12James Robinson (JAC)$4,30026.2Alvin Kamara (NO)$6,00026.1Davante Adams (GB)$7,20029.8Ja'Marr Chase (CIN)$4,20026.4DeSean Jackson (LAR)$7,30025.7Mark Andrews (BAL)$5,00018.9Mike Evans$6,30021.6Cleveland Browns (CLE)$3,2001649800218.82
13Aaron Rodgers (GB)$5,50018.58Peyton Barber (LV)$6,40026.6James Robinson (JAC)$4,30026.2Emmanuel Sanders (BUF)$6,80030.6Davante Adams (GB)$7,20029.8Ja'Marr Chase (CIN)$4,20026.4Zach Ertz (PHI)$2,90020Derrick Henry$8,60022.4Denver Broncos (DEN)$3,0001848900218.58
14Baker Mayfield (CLE)$5,70018.22Peyton Barber (LV)$6,40026.6James Robinson (JAC)$4,30026.2Emmanuel Sanders (BUF)$6,80030.6Davante Adams (GB)$7,20029.8Ja'Marr Chase (CIN)$4,20026.4Zach Ertz (PHI)$2,90020Derrick Henry$8,60022.4Denver Broncos (DEN)$3,0001849100218.22
15Russell Wilson (SEA)$6,00016.94Peyton Barber (LV)$6,40026.6James Robinson (JAC)$4,30026.2Emmanuel Sanders (BUF)$6,80030.6Davante Adams (GB)$7,20029.8Ja'Marr Chase (CIN)$4,20026.4Zach Ertz (PHI)$2,90020Derrick Henry$8,60022.4Denver Broncos (DEN)$3,0001849400216.94
16Daniel Jones (NYG)$5,60016.68Peyton Barber (LV)$6,40026.6James Robinson (JAC)$4,30026.2Emmanuel Sanders (BUF)$6,80030.6Davante Adams (GB)$7,20029.8Ja'Marr Chase (CIN)$4,20026.4Zach Ertz (PHI)$2,90020Derrick Henry$8,60022.4Denver Broncos (DEN)$3,0001849000216.68
17Matt Ryan (ATL)$5,40016.62Peyton Barber (LV)$6,40026.6James Robinson (JAC)$4,30026.2Emmanuel Sanders (BUF)$6,80030.6Davante Adams (GB)$7,20029.8Ja'Marr Chase (CIN)$4,20026.4Zach Ertz (PHI)$2,90020Derrick Henry$8,60022.4Denver Broncos (DEN)$3,0001848800216.62
18Ben Roethlisberger (PIT)$5,80016.54Peyton Barber (LV)$6,40026.6James Robinson (JAC)$4,30026.2Emmanuel Sanders (BUF)$6,80030.6Davante Adams (GB)$7,20029.8Ja'Marr Chase (CIN)$4,20026.4Zach Ertz (PHI)$2,90020Derrick Henry$8,60022.4Denver Broncos (DEN)$3,0001849200216.54
19Josh Allen (BUF)$7,00040.22Kareem Hunt (CLE)$5,60027.5Ezekiel Elliott (DAL)$6,60031.2Justin Jefferson (MIN)$3,00024D.K. Metcalf (SEA)$6,20023.7Kendrick Bourne (NE)$5,90023.5George Kittle (SF)$3,40015.3Clyde Edwards-Helaire$4,80020.9Los Angeles Chargers (LAC)$2,7001045200216.32
20Ryan Tannehill (TEN)$5,90025.24James Robinson (JAC)$4,30026.2Alvin Kamara (NO)$6,00026.1Davante Adams (GB)$7,20029.8Ja'Marr Chase (CIN)$4,20026.4DeSean Jackson (LAR)$7,30025.7Mark Andrews (BAL)$5,00018.9Mike Evans$6,30021.6Cleveland Browns (CLE)$3,2001649400215.94
21Mac Jones (NE)$5,10014.6Peyton Barber (LV)$6,40026.6James Robinson (JAC)$4,30026.2Emmanuel Sanders (BUF)$6,80030.6Davante Adams (GB)$7,20029.8Ja'Marr Chase (CIN)$4,20026.4Zach Ertz (PHI)$2,90020Derrick Henry$8,60022.4Denver Broncos (DEN)$3,0001848500214.6
DESIRED_RESULT_SET
 
Upvote 0
You will have to add a few worksheets to your existing ones: "Output", "Dupes", "Unique Names", "Position"

After updating the Full Data Set worksheet use 'subCheckForDupesAndUniques' to check for near-duplicates and unique name counts. Results appear on the 'Dupes' and 'Unique Names' worksheets

Use 'subProcess' to start processing after above validation is done. If you are resuming calculation from a save, you should choose Yes to start from saved position when given the option.

Pressing CapsLock during processing will halt execution, save the position of the calculation in the data space and display progress so far then offer an option to continue or stop.

This code in a standard module:
VBA Code: 
Option Explicit
'https://www.mrexcel.com/board/threads/all-combinations-of-multiple-columns-without-duplicates.1106189/page-2#post-5799308

Sub subCheckForDupesAndUniques()
    'Examines the 'Full Data Set' worksheets and shows duplciates and uniques on the
    '  'Dupes' and 'Unique Names' worksheets.  Review thes woresheets and make needed
    '  corrections to 'Full Data Set'
    
    Dim aryConcat As Variant
    Dim lIndexCol As Long
    Dim lIndexRow As Long
    Dim lLastRow As Long
    Dim lLastCol As Long
    Dim sType As String
    Dim lSpacePos As Long
    Dim lWriteRow As Long
    Dim sNameTeam As String
    
    Dim varK As Variant, varI As Variant, varTemp As Variant, lIndex As Long
    Dim oSD As Object
    Set oSD = CreateObject("Scripting.Dictionary")
    oSD.CompareMode = vbTextCompare
    
    Worksheets("Unique Names").UsedRange.Cells.Clear
    Worksheets("Dupes").UsedRange.Cells.Clear
    lWriteRow = 1
    Worksheets("Dupes").Cells(lWriteRow, 1).Resize(1, 5).Value = Array("Name", "Cost", "FPTS", "Type", "Row")
    With Worksheets("Full Data Set")
        lLastCol = .Cells(1#, Columns.Count).End(xlToLeft).Column
        For lIndexCol = 1 To lLastCol Step 3
            lLastRow = .Cells(.Rows.Count, lIndexCol).End(xlUp).Row
            sType = Trim(.Cells(1, lIndexCol))
            lSpacePos = InStr(sType, " ")
            If lSpacePos > 0 Then sType = Left(sType, lSpacePos - 1)
            For lIndexRow = 2 To lLastRow
                sNameTeam = Trim(.Cells(lIndexRow, lIndexCol).Value)
                oSD.Item(sNameTeam) = oSD.Item(sNameTeam) + 1
                aryConcat = Array(sNameTeam, _
                    Trim(.Cells(lIndexRow, lIndexCol + 1).Value), _
                    Trim(.Cells(lIndexRow, lIndexCol + 2).Value), _
                    sType, lIndexRow)
                lWriteRow = lWriteRow + 1
                Worksheets("Dupes").Cells(lWriteRow, 1).Resize(1, 5).Value = aryConcat
            Next
        Next
    End With
    
    If oSD.Count > 0 Then
        ReDim varTemp(1 To 2, 1 To oSD.Count)
        varK = oSD.keys: varI = oSD.Items
        For lIndex = 1 To oSD.Count
            varTemp(1, lIndex) = varK(lIndex - 1): varTemp(2, lIndex) = varI(lIndex - 1)
        Next
    
        'Write to Worksheet
        Worksheets("Unique Names").Range("A1").Resize(1, 3).Value = Array("Name", "Count", "Code")
        Worksheets("Unique Names").Range("A2").Resize(oSD.Count, 2).Value = Application.Transpose(varTemp)
        
        ActiveWorkbook.Worksheets("Unique Names").Sort.SortFields.Clear
        ActiveWorkbook.Worksheets("Unique Names").Sort.SortFields.Add Key:=Range( _
            "A2:A" & oSD.Count + 1), SortOn:=xlSortOnValues, Order:=xlAscending, DataOption:= _
            xlSortNormal
        With ActiveWorkbook.Worksheets("Unique Names").Sort
            .SetRange Range("A1:C" & oSD.Count + 1)
            .Header = xlYes
            .MatchCase = False
            .Orientation = xlTopToBottom
            .SortMethod = xlPinYin
            .Apply
        End With
        
    End If

    With ActiveWorkbook.Worksheets("Dupes")
        lLastRow = .Cells(.Rows.Count, 1).End(xlUp).Row
        .Sort.SortFields.Clear
        .Sort.SortFields.Add Key:=Range( _
            "A2:A" & lLastRow), SortOn:=xlSortOnValues, Order:=xlAscending, DataOption:= _
        xlSortNormal
        With ActiveWorkbook.Worksheets("Dupes").Sort
            .SetRange Range("A1:E" & lLastRow)
            .Header = xlYes
            .MatchCase = False
            .Orientation = xlTopToBottom
            .SortMethod = xlPinYin
            .Apply
        End With
        
    End With
    
    Application.Goto Worksheets("Dupes").Range("A1"), Scroll:=True
    AlternateRangeRowColorBasedOnColumnChange
    
End Sub

Sub AlternateRangeRowColorBasedOnColumnChange()
    'Alternate row colors as column lCheckCol changes
    'This is best used if the range is sorted on column lCheckCol
    'Revised 2021-12-11
    
    Const lCheckCol As Long = 1
    Dim rngRow As Range
    Dim rngDatabase As Range
    Dim strPrevious As String
    Dim intColor1 As Integer
    Dim intColor2 As Integer
    Dim intCurrentColor As Integer
    Dim dblChecked As Double
    
    Set rngDatabase = ActiveSheet.UsedRange
    strPrevious = ""
    intColor1 = 15
    intColor2 = 2
    
    strPrevious = Cells(rngDatabase.Rows(1).Row, lCheckCol).Value
    
    'Clear existing fill colors
    rngDatabase.Cells.Interior.ColorIndex = intColor1
    
    For Each rngRow In rngDatabase.Rows
        If Cells(rngRow.Row, lCheckCol).Value <> strPrevious Then
            If intCurrentColor = intColor1 Then
                intCurrentColor = intColor2
            Else
                intCurrentColor = intColor1
            End If
            strPrevious = Cells(rngRow.Row, lCheckCol).Value
        End If
        rngRow.Cells.Interior.ColorIndex = intCurrentColor
    Next rngRow
    Set rngDatabase = Nothing
    
End Sub

Sub subProcess()

    Const lCostMax As Long = 50001
    Const sngFPTSMax As Single = 200.01
    
    Dim aryData As Variant
    Dim aryIndex(1 To 9) As Variant
    Dim lCost As Long
    Dim sngFPTS As Single
    Dim lCol As Long
    Dim lRow As Long
    Dim lIndex As Long
    Dim lCarry As Long
    Dim sName As String
    Dim lOffset As Long
    Dim lWriteRow As Long
    Dim lLastPosRow As Long
    Dim lLastRow As Long
    Dim dblChecked As Double
    Dim sStatus As String
    Dim dteTime As Date
    Dim lGoodCount As Long
    
    Dim oSD As Object
    Set oSD = CreateObject("Scripting.Dictionary")
    oSD.CompareMode = vbTextCompare
    
    Worksheets("Output").Range("A1").Resize(1, 29).Value = Array("QB NAME", "QB COST", "QB FPTS", "RB1 NAME", "RB1 COST", "RB1 FPTS", "RB2 NAME", "RB2 COST", "RB2 FPTS", "WR1 NAME", "WR1 COST", "WR1 FPTS", "WR2 NAME", "WR2 COST", "WR2 FPTS", "WR3 NAME", "WR3 COST", "WR3 FPTS", "TE NAME", "TE COST", "TE FPTS", "FLEX NAME", "FLEX COST", "FLEX FPTS", "DEFENSE NAME", "DEFENSE COST", "DEFENSE FPTS", "TOTAL COST", "TOTAL FPTS")
    Worksheets("Dupes").Range("A1").Resize(1, 5).Value = Array("Name", "Cost", "FPTS", "Type", "Row")
    Worksheets("Unique Names").Range("A1").Resize(1, 2).Value = Array("Name", "Count")
    Worksheets("Position").Range("A1").Resize(1, 9).Value = Array("1", "2", "3", "4", "5", "6", "7", "8", "9")
    
    dteTime = Now()
    
    Application.ScreenUpdating = False
    
    aryData = Worksheets("Full Data Set").Range("A1:AA20").Value
    
    'Initialize Indices
    For lIndex = 1 To 9
        aryIndex(lIndex) = 2
    Next
    
    'Restore last position
    With Worksheets("Position")
        lLastPosRow = .Cells(.Rows.Count, 1).End(xlUp).Row
        If lLastPosRow > 1 Then
            Select Case MsgBox("Do you want to start from the last saved position?" & vbLf & vbLf & _
            "    Yes" & vbTab & " to start from saved position" & vbLf & _
            "    No" & vbTab & " to start over", vbYesNo, "Start from last save ? ")
            Case vbYes
                For lIndex = 1 To 9
                    aryIndex(lIndex) = .Cells(lLastPosRow, lIndex)
                Next
            End Select
        End If
    End With
    
    'Next row for good output
    With Worksheets("Output")
        lWriteRow = .Cells(.Rows.Count, 1).End(xlUp).Row + 1
    End With
    
    Do
'        For lIndex = 1 To 9
'            Debug.Print aryIndex(lIndex);
'        Next
'        Debug.Print

        'Calculate Next row
        For lIndex = 1 To 9
            lOffset = (3 * lIndex) - 2                      '1,4,7,10,13,16,19,22,25
            sName = aryData(aryIndex(lIndex), lOffset)
            oSD.Item(sName) = oSD.Item(sName) + 1
            lCost = lCost + aryData(aryIndex(lIndex), lOffset + 1)
            sngFPTS = sngFPTS + aryData(aryIndex(lIndex), lOffset + 2)
        Next

        'Good Row?
        If lCost < lCostMax And sngFPTS < sngFPTSMax And oSD.Count = 9 Then
            'VBA.Beep: Stop
            For lIndex = 1 To 9
                With Worksheets("Output")
                    lOffset = (3 * lIndex) - 2                      '1,4,7,10,13,16,19,22,25
                    .Cells(lWriteRow, lOffset).Value = aryData(aryIndex(lIndex), lOffset)
                    .Cells(lWriteRow, lOffset + 1).Value = aryData(aryIndex(lIndex), lOffset + 1)
                    .Cells(lWriteRow, lOffset + 2).Value = aryData(aryIndex(lIndex), lOffset + 2)
                End With
            Next
            lWriteRow = lWriteRow + 1
        End If

        'Reset counters
        lCost = 0: sngFPTS = 0: oSD.RemoveAll

        'Increment Row Indices
        For lIndex = 9 To 1 Step -1
            If lIndex = 9 Then
                aryIndex(lIndex) = aryIndex(lIndex) + 1
                If aryIndex(lIndex) = 21 Then aryIndex(lIndex) = 2: lCarry = 1
            Else
                aryIndex(lIndex) = aryIndex(lIndex) + lCarry
                lCarry = 0
                If aryIndex(9) = 21 Then Exit Do
                If aryIndex(lIndex) = 21 Then aryIndex(lIndex) = 2: lCarry = 1
            End If
        Next

        DoEvents
        If CapsLockOn Then
            dblChecked = 0
            lLastPosRow = Worksheets("Position").Cells(Rows.Count, 1).End(xlUp).Row + 1
            For lIndex = 1 To 9
                Worksheets("Position").Cells(lLastPosRow, lIndex) = aryIndex(lIndex)
                Debug.Print aryIndex(lIndex);
                dblChecked = dblChecked + (aryIndex(lIndex) - 2) * 19 ^ (9 - lIndex)
            Next
            lGoodCount = Worksheets("Output").Cells(Rows.Count, 1).End(xlUp).Row - 1
            sStatus = Format(dblChecked, "#,###") & " Checked, " & _
                lGoodCount & " met criteria (" & _
                Format(Now() - dteTime, "hh:mm:ss")
            Debug.Print vbTab & sStatus
            Application.ScreenUpdating = True
            Application.StatusBar = sStatus
            
            'Exit if Output worksheet nearly full
            If lGoodCount > 1048570 Then Exit Do

            Select Case MsgBox("Do you want to continue processing or save position and exit ?" & vbLf & vbLf & _
            "Turn off CapsLock then:" & vbLf & vbLf & _
            "    Yes" & vbTab & " Continue processing" & vbLf & _
            "    No" & vbTab & " Stop, save position and Exit", vbYesNo, "Continue Processing ? ")
            Case vbNo
                Exit Do
            End Select
        End If
    Loop
    
    'Update Output Total Columns
    With Worksheets("Output")
        lLastRow = .Cells(.Rows.Count, 1).End(xlUp).Row
        With .Range(.Cells(2, 28), .Cells(lLastRow, 29))
            .FormulaR1C1 = "=RC[-2]+RC[-5]+RC[-8]+RC[-11]+RC[-14]+RC[-17]+RC[-20]+RC[-23]+RC[-26]"
            Application.Calculate
            .Value = .Value
        End With
    End With

    Application.StatusBar = False
    Application.ScreenUpdating = True

    VBA.Beep

End Sub

This code in another standard module:

VBA Code: 
Option Explicit

Private Declare PtrSafe Function GetKeyState Lib "user32" _
     (ByVal nVirtKey As Long) As Integer

' Constant declarations:
Const VK_NUMLOCK = &H90
Const VK_SCROLL = &H91
Const VK_CAPITAL = &H14

 Function CapsLockOn() As Boolean
     CapsLockOn = (GetKeyState(vbKeyCapital) And 1)
 End Function
 
Upvote 0
You must log in or register to reply here.

Similar threads

V
  • Solved
Show duplicates from across multiple ranges in one cell with a single nested formula?
Replies
9
Views
144
VikingLink
V
S
  • Question Question
Deleting multiple rows, columns, unmerging, pivot table all at once.
Replies
2
Views
93
HighAndWilder
H
A
  • Question Question
All Combinations No Duplicates Macro
Replies
1
Views
849
andrew_milonavic
A
R
  • Solved
Combine Multiple rows and delete duplicates in multiple columns
Replies
5
Views
831
Alex Blakenburg
A
J
  • Solved
Filter on Multiple Criteria
Replies
4
Views
389
Peter_SSs
Peter_SSs

Forum statistics

Threads
1,223,227
Messages
6,170,848
Members
452,361
Latest member
d3ad3y3

Share this page

We've detected that you are using an adblocker.

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

Which adblocker are you using?

Disable AdBlock

Follow these easy steps to disable AdBlock

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

Disable AdBlock Plus

Follow these easy steps to disable AdBlock Plus

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

Disable uBlock Origin

Follow these easy steps to disable uBlock Origin

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

Disable uBlock

Follow these easy steps to disable uBlock

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