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.
 

Excel Facts

Save Often
If you start asking yourself if now is a good time to save your Excel workbook, the answer is Yes
Sort by date Sort by votes
Your example had 233,280 combinations of which 3236 met your requirements.

Code: 
Option Explicit

Sub NameCombos()
    'https://www.mrexcel.com/forum/excel-questions/1106189-all-combinations-multiple-columns-without-duplicates.html
    
    Dim lLastColumn 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 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
    
    lLastColumn = Range("A1").CurrentRegion.Columns.Count
    ReDim aryNames(1 To 2, 1 To lLastColumn)    '1 holds the in-use entry row
                                                '2 holds the max entry
                                                
    '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) + 2
    
    'Clear Output Range
    'Range(Cells(1, lFirstWriteColumn), Cells(1, lLastWriteColumn)).EntireColumn.ClearContents
    
    'Add Output Header
    Range(Cells(1, 1), Cells(1, lLastColumn)).Copy Destination:=Cells(1, lFirstWriteColumn)
    
    lWriteRow = 2
    
    For lIterationCount = 1 To lLastIteration
        If lIterationCount / 1000 = lIterationCount \ 1000 Then Application.StatusBar = lIterationCount
        
        'Check Active Combo for Dupe Names
        bDupeName = False
        Set oSD = CreateObject("Scripting.Dictionary")
        oSD.CompareMode = vbTextCompare
        
        For lColumnIndex = lLastColumn To 1 Step -1
            sName = Cells(aryNames(1, lColumnIndex), lColumnIndex).Value
            oSD.Item(sName) = oSD.Item(sName) + 1
        Next

        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
    
            'Print Active Combo
            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
            lWriteRow = lWriteRow + 1
            
            'Uncomment next row to see the lIterationCount for the printed row
            'Cells(lWriteRow, lLastWriteColumn + 1).Value = lIterationCount
            
        End If
    
        'Increment Counters
        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
    
    MsgBox lLastIteration & " combinations" & vbLf & _
        lWriteRow - 2 & " printed."
End Sub
 
Upvote 0
Added some code to handle duplicate rows which will occur when the same name is in a single column.

Code: 
Option Explicit

Sub NameCombos()
    'https://www.mrexcel.com/forum/excel-questions/1106189-all-combinations-multiple-columns-without-duplicates.html
    
    Dim lLastColumn 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 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
    
    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
    
    lLastColumn = Range("A1").CurrentRegion.Columns.Count
    ReDim aryNames(1 To 2, 1 To lLastColumn)    '1 holds the in-use entry row
                                                '2 holds the max entry
                                                
    '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 " & Replace(Range(Cells(1, lFirstWriteColumn - 1), _
        Cells(1, lLastWriteColumn + 1)).Columns.Address(0, 0), "1", "") & _
        " will be erased before continuing.", vbOKCancel + vbCritical + _
        vbDefaultButton2, "Process table?")
    Case vbCancel
        GoTo End_Sub
    End Select
    
    'Clear Output Range
    Range(Cells(1, lFirstWriteColumn - 1), Cells(1, lLastWriteColumn + 1)).EntireColumn.ClearContents
    
    'Add Output Header
    Range(Cells(1, 1), Cells(1, lLastColumn)).Copy Destination:=Cells(1, lFirstWriteColumn)
    
    lWriteRow = 2
    
    For lIterationCount = 1 To lLastIteration
        If lIterationCount / 1000 = lIterationCount \ 1000 Then Application.StatusBar = lIterationCount
        
        'Check Active Combo for Dupe Names
        bDupeName = False
        Set oSD = CreateObject("Scripting.Dictionary")
        oSD.CompareMode = vbTextCompare
        
        For lColumnIndex = lLastColumn To 1 Step -1
            sName = Cells(aryNames(1, lColumnIndex), lColumnIndex).Value
            oSD.Item(sName) = oSD.Item(sName) + 1
        Next

        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
    
            'Print Active Combo
            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
            
            lWriteRow = lWriteRow + 1
            
        End If
    
        'Increment Counters
        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
    
    'Check for duplicate rows
    '  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 lLastWriteColumn - lFirstWriteColumn)
    lIndex = 0
    For lColumnIndex = lFirstWriteColumn To lLastWriteColumn
        aryDeDupe(lIndex) = CInt(lIndex + 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
    
    MsgBox 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.", , "Output Report"
        
End_Sub:
    
End Sub
 
Upvote 0
And finished the error checking I got distracted from:

Code: 
Option Explicit

Sub NameCombos()
    'https://www.mrexcel.com/forum/excel-questions/1106189-all-combinations-multiple-columns-without-duplicates.html
    
    Dim lLastColumn 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 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
    
    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
    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 " & Replace(Range(Cells(1, lFirstWriteColumn - 1), _
        Cells(1, lLastWriteColumn + 1)).Columns.Address(0, 0), "1", "") & _
        " will be erased before continuing.", vbOKCancel + vbCritical + _
        vbDefaultButton2, "Process table?")
    Case vbCancel
        GoTo End_Sub
    End Select
    
    'Clear Output Range
    Range(Cells(1, lFirstWriteColumn - 1), Cells(1, lLastWriteColumn + 1)).EntireColumn.ClearContents
    
    'Add Output Header
    Range(Cells(1, 1), Cells(1, lLastColumn)).Copy Destination:=Cells(1, lFirstWriteColumn)
    
    lWriteRow = 2
    
    For lIterationCount = 1 To lLastIteration
        If lIterationCount / 1000 = lIterationCount \ 1000 Then Application.StatusBar = lIterationCount
        
        'Check Active Combo for Dupe Names
        bDupeName = False
        Set oSD = CreateObject("Scripting.Dictionary")
        oSD.CompareMode = vbTextCompare
        
        For lColumnIndex = lLastColumn To 1 Step -1
            sName = Cells(aryNames(1, lColumnIndex), lColumnIndex).Value
            oSD.Item(sName) = oSD.Item(sName) + 1
        Next

        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
    
            'Print Active Combo
            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
            
            lWriteRow = lWriteRow + 1
            
        End If
    
        'Increment Counters
        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
    
    'Check for duplicate rows
    '  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 lLastWriteColumn - lFirstWriteColumn)
    lIndex = 0
    For lColumnIndex = lFirstWriteColumn To lLastWriteColumn
        aryDeDupe(lIndex) = CInt(lIndex + 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
    
    MsgBox 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.", , "Output Report"
        
End_Sub:
    
End Sub
 
Upvote 0
Wow! Thank you very much. I only had a moment to take a look at it and it seems to be exactly what I was looking for. I really appreciate you going through the trouble of doing that. Just out of curiosity, if I needed to add one more variable to it which would limit the output even more, would that be difficult to achieve? For example if each name came had a corresponding salary attached to them (in a column on another sheet) and the sum of the 10 people’s salary had to stay between two designated totals without exceeding it (ie. $45k-$50k)? If that would be at all possible I can detail it further as to what I am trying to do if necessary. If it’s too much trouble, not to worry. Thanks again!
 
Upvote 0
Phil,

First of all thank you again for your help on this. I was finally able to work with it some more since I got home and I noticed one issue I am struggling with aside from my previous post requesting the possibility for additional variables. The results generated are preventing duplicates of any unique name within any row, which is what I was looking for, however I am getting many duplicate combinations due to them coming up in a different order. Would there be any way to prevent this from happening so that only one set of the 10 names is generated for each combination? In other words, alleviate the following where all these 5 rows would actually only need to be 1 row since they are all the same, just ordered differently. This is happening in all columns throughout the results and not just limited to the first two or last 3 since I have many duplicate names multiple columns in the source range. If all the same 10 names exist in any order, I only need that result generated one time and regardless of the order it appears as long as each name remains in any one of the columns they were initially (Ed and Joe may both only be in A and B, so they can be generated in either L or M only, etc.). Thanks again.

[TABLE="width: 500"]
<tbody>[TR]
[TD]Ed[/TD]
[TD]Joe[/TD]
[TD]Mike
[/TD]
[TD]Steve[/TD]
[TD]Bob[/TD]
[TD]Jeff[/TD]
[TD]Linda[/TD]
[TD]Aaron[/TD]
[TD]Max[/TD]
[TD]Matt[/TD]
[/TR]
[TR]
[TD]Ed[/TD]
[TD]Joe[/TD]
[TD]Mike[/TD]
[TD]Steve[/TD]
[TD]Bob[/TD]
[TD]Jeff[/TD]
[TD]Linda[/TD]
[TD]Matt[/TD]
[TD]Aaron[/TD]
[TD]Max[/TD]
[/TR]
[TR]
[TD]Ed[/TD]
[TD]Joe[/TD]
[TD]Mike[/TD]
[TD]Steve[/TD]
[TD]Bob[/TD]
[TD]Jeff[/TD]
[TD]Linda[/TD]
[TD]Max[/TD]
[TD]Matt[/TD]
[TD]Aaron
[/TD]
[/TR]
[TR]
[TD]Joe[/TD]
[TD]Ed[/TD]
[TD]Mike[/TD]
[TD]Steve[/TD]
[TD]Bob[/TD]
[TD]Jeff[/TD]
[TD]Linda[/TD]
[TD]Aaron[/TD]
[TD]Max[/TD]
[TD]Matt[/TD]
[/TR]
[TR]
[TD]Joe[/TD]
[TD]Ed[/TD]
[TD]Mike[/TD]
[TD]Steve[/TD]
[TD]Bob[/TD]
[TD]Jeff[/TD]
[TD]Linda[/TD]
[TD]Aaron[/TD]
[TD]Matt[/TD]
[TD]Max[/TD]
[/TR]
</tbody>[/TABLE]

Only Need...
[TABLE="width: 500"]
<tbody>[TR]
[TD]Ed[/TD]
[TD]Joe[/TD]
[TD]Mike[/TD]
[TD]Steve[/TD]
[TD]Bob[/TD]
[TD]Jeff[/TD]
[TD]Linda[/TD]
[TD]Aaron[/TD]
[TD]Max[/TD]
[TD]Matt[/TD]
[/TR]
</tbody>[/TABLE]
 
Upvote 0
Test totals on a subset.

Code: 
Option Explicit

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 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 rngSortRange As Range
    Dim dteStart As Date
    Dim sOutput As String
    Dim lFirstHSortColumn As Long
    Dim lLastHSortColumn As Long
    Dim lLastSalaryRow As Long
    Dim rngReplace As Range
    
    Application.StatusBar = False
    
    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)
    
    lWriteRow = 2
    For lIterationCount = 1 To lLastIteration
        If lIterationCount / 1000 = lIterationCount \ 1000 Then Application.StatusBar = _
            lIterationCount & " / " & lLastIteration
        'Check Active Combo for Dupe Names
        bDupeName = False
        Set oSD = CreateObject("Scripting.Dictionary")
        oSD.CompareMode = vbTextCompare
        
        For lColumnIndex = lLastColumn To 1 Step -1
            sName = Cells(aryNames(1, lColumnIndex), lColumnIndex).Value
            oSD.Item(sName) = oSD.Item(sName) + 1
        Next

        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
    
            'Print Active Combo
            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
            
            lWriteRow = lWriteRow + 1
            
        End If
    
        'Increment Counters
        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
    
    'Sort Each Row
    'Copy Sorted names to right
    lLastRow = Cells(Rows.Count, lFirstWriteColumn).End(xlUp).Row
    Range(Cells(1, lFirstWriteColumn), Cells(lLastRow, lLastWriteColumn)).Copy Destination:=Cells(1, lLastWriteColumn + 2)
    lFirstHSortColumn = lLastWriteColumn + 2
    lLastHSortColumn = Cells(1, Columns.Count).End(xlToLeft).Column
    
    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
    
    '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")
        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
    
    'Add Sum Column
    Cells(1, lLastHSortColumn + 1).Value = "Sum"
    With Range(Cells(2, lLastHSortColumn + 1), Cells(lLastRowDeDuped, lLastHSortColumn + 1))
        .FormulaR1C1 = "=SUM(RC" & lFirstHSortColumn & ":RC" & lLastHSortColumn & ")"
        Application.Calculate
        .Value = .Value
    End With
    'Remove Salary Columns
    Range(Cells(2, lFirstHSortColumn), Cells(lLastRowDeDuped, lLastHSortColumn)).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
    Application.ScreenUpdating = True
    Application.StatusBar = False
    MsgBox sOutput, , "Output Report"
    Debug.Print sOutput
        
End_Sub:
    
End Sub
 
Upvote 0
Phil,

Once again thank you for your help on this. I apologize for apparently not being clear on what I needed exactly. I wish I hadn't posted the first reply regarding the salaries, etc. Although I would like that, it seems to have caused some issues. I received a "Run-time error '9' Subscript out of range".

In my follow up reply after that one, I mentioned that I was looking for it to eliminate duplicate rows when the same data appeared in a different order. I was able to see that you were successful in getting that to happen, however I noticed that an additional set of columns generated to the right and sorted what appears to be alphabetically left to right from A-Z. That is not what I needed. At this point, and I apologize for being a pest about all this, if you wouldn't mind simply having it generate without the additional set of columns, that would be much appreciated.

Forget about the salary variable since that seems to be more than I feel I should be asking for. I tried to edit the code down to simply generating one instance without sorting anything, but wasn't able to do so. Each of the column headers signifies a position, and the last three are the same and the only places those names can reside in, same with some other columns. This is the reason for not wanting to sort them. All instances of any of the generated rows are valid, but I only need one of them, and I am getting multiple on the original script, but not the new one you posted,which is perfect. I just don't need the sorts to show up to the right of it.

[TABLE="class: cms_table, width: 500"]
<tbody>[TR]
[TD]Ed[/TD]
[TD]Joe[/TD]
[TD]Mike[/TD]
[TD]Steve[/TD]
[TD]Bob[/TD]
[TD]Jeff[/TD]
[TD]Linda[/TD]
[TD]Aaron[/TD]
[TD]Max[/TD]
[TD]Matt[/TD]
[/TR]
[TR]
[TD]Ed[/TD]
[TD]Joe[/TD]
[TD]Mike[/TD]
[TD]Steve[/TD]
[TD]Bob[/TD]
[TD]Jeff[/TD]
[TD]Linda[/TD]
[TD]Matt[/TD]
[TD]Aaron[/TD]
[TD]Max[/TD]
[/TR]
[TR]
[TD]Ed[/TD]
[TD]Joe[/TD]
[TD]Mike[/TD]
[TD]Steve[/TD]
[TD]Bob[/TD]
[TD]Jeff[/TD]
[TD]Linda[/TD]
[TD]Max[/TD]
[TD]Matt[/TD]
[TD]Aaron[/TD]
[/TR]
[TR]
[TD]Joe[/TD]
[TD]Ed[/TD]
[TD]Mike[/TD]
[TD]Steve[/TD]
[TD]Bob[/TD]
[TD]Jeff[/TD]
[TD]Linda[/TD]
[TD]Aaron[/TD]
[TD]Max[/TD]
[TD]Matt[/TD]
[/TR]
[TR]
[TD]Joe[/TD]
[TD]Ed[/TD]
[TD]Mike[/TD]
[TD]Steve[/TD]
[TD]Bob[/TD]
[TD]Jeff[/TD]
[TD]Linda[/TD]
[TD]Aaron[/TD]
[TD]Matt[/TD]
[TD]Max[/TD]
[/TR]
</tbody>[/TABLE]

Only Need 1 of these such as...[TABLE="class: cms_table, width: 500"]
<tbody>[TR]
[TD]Ed[/TD]
[TD]Joe[/TD]
[TD]Mike[/TD]
[TD]Steve[/TD]
[TD]Bob[/TD]
[TD]Jeff[/TD]
[TD]Linda[/TD]
[TD]Aaron[/TD]
[TD]Max[/TD]
[TD]Matt[/TD]
[/TR]
</tbody>[/TABLE]

No sorting

I feel like I owe you for all your trouble so please let me know how can compensate you for all this if you don't mind.
 
Upvote 0
What line in code was highlighted when you received the error?

I tested it with various name/column combinations (including your original layout) and dummy salaries and did not get an error (although it did tale about 6 minutes to run).

I believe it was: With Worksheets("Salary")

The version in post #7 must have a worksheet named Salary; with the first data row is 2 with column A holding names of the folks on the first names in columns sheet and column B holding their salaries.

I did mention it in the code, but not in the preface to the code. But adding the worksheet should eliminate the problem

I needed to generate the additional columns and sort left to right in order to check for duplicates when the rows were in alphabetical order.
After duplicate rows are removed the names in the extra horizontally sorted columns are replaced with corresponding salary values from the Salary worksheet.
The extra horizontally sorted columns are totaled then deleted.

After the program stops, use autofilter to show only the salary range your are interested in.
I added some comments to the code in post #7 and a bit more error checking.

Please test this version after adding the filled in Salary worksheet and let me know the results.

Code: 
Option Explicit

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 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 rngSortRange As Range
    Dim dteStart As Date
    Dim sOutput As String
    Dim lFirstHSortColumn As Long
    Dim lLastHSortColumn As Long
    Dim lLastSalaryRow As Long
    Dim rngReplace As Range
    Dim wks As Worksheet
    Dim bFoundSalary As Boolean
    Dim sMissingSalary As String
    
    
    Application.StatusBar = False
    
    '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 <> vbnulltring 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)
    lFirstHSortColumn = lLastWriteColumn + 2
    lLastHSortColumn = Cells(1, Columns.Count).End(xlToLeft).Column
    
    '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
    
    '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")
        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
    
    'Add Sum Column
    Cells(1, lLastHSortColumn + 1).Value = ChrW(931) & " Salary"
    With Range(Cells(2, lLastHSortColumn + 1), Cells(lLastRowDeDuped, lLastHSortColumn + 1))
        .FormulaR1C1 = "=SUM(RC" & lFirstHSortColumn & ":RC" & lLastHSortColumn & ")"
        Application.Calculate
        .Value = .Value
    End With
    'Remove Salary Columns
    Range(Cells(2, lFirstHSortColumn), Cells(lLastRowDeDuped, lLastHSortColumn)).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:

    Application.ScreenUpdating = True
    Application.StatusBar = False
    
End Sub
 
Upvote 0
Phil,

I completely missed the part about needing a sheet named "salary". I went ahead and did that and it seems to be working perfectly. I cannot thank you enough. I apologize for the confusion on my end and the back and forth.

Sincerely,

Seth
 
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