Page 1 of 2 12 LastLast
Results 1 to 10 of 12

Thread: All Combinations of Multiple Columns Without Duplicates
Thanks Thanks: 0 Likes Likes: 0

  1. #1
    New Member
    Join Date
    Aug 2019
    Posts
    8
    Post Thanks / Like
    Mentioned
    0 Post(s)
    Tagged
    0 Thread(s)

    Default All Combinations of Multiple Columns Without Duplicates

    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.

    1 2 3 4 5 6 7 8 9 10 1 2 3 4 5 6 7 8 9 10
    Joe Mike Ed Linda Ed Mike Don Chris Kevin Chris Joe Mike Steve Linda Ed Jeff Don Chris Kevin Harold
    John Ed Mike Maria John Jeff George Mike Earl Ed Joe Ed Mike Linda John Jeff Don Chris Kevin Steve
    Steve Jack Steve Jack Joe Dale Jack John Ed Mike
    Joe Ed John Steve
    Harold


    Thank you for any help provided.

  2. #2
    Board Regular pbornemeier's Avatar
    Join Date
    May 2005
    Location
    Virginia Beach, VA USA
    Posts
    3,659
    Post Thanks / Like
    Mentioned
    0 Post(s)
    Tagged
    1 Thread(s)

    Default Re: All Combinations of Multiple Columns Without Duplicates

    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
    Phil

    - Use CODE tags to keep your code formatted. See: BB Tags
    - How to attach Screenshots
    - Try searching for your answer first, see how
    - Test and validate results for all code on a copy of your worksheet!! How do you use the code you just found?
    - Posting guidelines, forum rules and terms of use
    - Read the FAQs

  3. #3
    Board Regular pbornemeier's Avatar
    Join Date
    May 2005
    Location
    Virginia Beach, VA USA
    Posts
    3,659
    Post Thanks / Like
    Mentioned
    0 Post(s)
    Tagged
    1 Thread(s)

    Default Re: All Combinations of Multiple Columns Without Duplicates

    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
    Phil

    - Use CODE tags to keep your code formatted. See: BB Tags
    - How to attach Screenshots
    - Try searching for your answer first, see how
    - Test and validate results for all code on a copy of your worksheet!! How do you use the code you just found?
    - Posting guidelines, forum rules and terms of use
    - Read the FAQs

  4. #4
    Board Regular pbornemeier's Avatar
    Join Date
    May 2005
    Location
    Virginia Beach, VA USA
    Posts
    3,659
    Post Thanks / Like
    Mentioned
    0 Post(s)
    Tagged
    1 Thread(s)

    Default Re: All Combinations of Multiple Columns Without Duplicates

    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
    Phil

    - Use CODE tags to keep your code formatted. See: BB Tags
    - How to attach Screenshots
    - Try searching for your answer first, see how
    - Test and validate results for all code on a copy of your worksheet!! How do you use the code you just found?
    - Posting guidelines, forum rules and terms of use
    - Read the FAQs

  5. #5
    New Member
    Join Date
    Aug 2019
    Posts
    8
    Post Thanks / Like
    Mentioned
    0 Post(s)
    Tagged
    0 Thread(s)

    Default Re: All Combinations of Multiple Columns Without Duplicates

    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 peoples 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 its too much trouble, not to worry. Thanks again!

  6. #6
    New Member
    Join Date
    Aug 2019
    Posts
    8
    Post Thanks / Like
    Mentioned
    0 Post(s)
    Tagged
    0 Thread(s)

    Default Re: All Combinations of Multiple Columns Without Duplicates

    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.
    Ed Joe Mike Steve Bob Jeff Linda Aaron Max Matt
    Ed Joe Mike Steve Bob Jeff Linda Matt Aaron Max
    Ed Joe Mike Steve Bob Jeff Linda Max Matt Aaron
    Joe Ed Mike Steve Bob Jeff Linda Aaron Max Matt
    Joe Ed Mike Steve Bob Jeff Linda Aaron Matt Max
    Only Need...
    Ed Joe Mike Steve Bob Jeff Linda Aaron Max Matt

  7. #7
    Board Regular pbornemeier's Avatar
    Join Date
    May 2005
    Location
    Virginia Beach, VA USA
    Posts
    3,659
    Post Thanks / Like
    Mentioned
    0 Post(s)
    Tagged
    1 Thread(s)

    Default Re: All Combinations of Multiple Columns Without Duplicates

    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
    Phil

    - Use CODE tags to keep your code formatted. See: BB Tags
    - How to attach Screenshots
    - Try searching for your answer first, see how
    - Test and validate results for all code on a copy of your worksheet!! How do you use the code you just found?
    - Posting guidelines, forum rules and terms of use
    - Read the FAQs

  8. #8
    New Member
    Join Date
    Aug 2019
    Posts
    8
    Post Thanks / Like
    Mentioned
    0 Post(s)
    Tagged
    0 Thread(s)

    Default Re: All Combinations of Multiple Columns Without Duplicates

    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.

    Ed Joe Mike Steve Bob Jeff Linda Aaron Max Matt
    Ed Joe Mike Steve Bob Jeff Linda Matt Aaron Max
    Ed Joe Mike Steve Bob Jeff Linda Max Matt Aaron
    Joe Ed Mike Steve Bob Jeff Linda Aaron Max Matt
    Joe Ed Mike Steve Bob Jeff Linda Aaron Matt Max

    Only Need 1 of these such as...
    Ed Joe Mike Steve Bob Jeff Linda Aaron Max Matt

    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.

  9. #9
    Board Regular pbornemeier's Avatar
    Join Date
    May 2005
    Location
    Virginia Beach, VA USA
    Posts
    3,659
    Post Thanks / Like
    Mentioned
    0 Post(s)
    Tagged
    1 Thread(s)

    Default Re: All Combinations of Multiple Columns Without Duplicates

    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
    Phil

    - Use CODE tags to keep your code formatted. See: BB Tags
    - How to attach Screenshots
    - Try searching for your answer first, see how
    - Test and validate results for all code on a copy of your worksheet!! How do you use the code you just found?
    - Posting guidelines, forum rules and terms of use
    - Read the FAQs

  10. #10
    New Member
    Join Date
    Aug 2019
    Posts
    8
    Post Thanks / Like
    Mentioned
    0 Post(s)
    Tagged
    0 Thread(s)

    Default Re: All Combinations of Multiple Columns Without Duplicates

    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

Some videos you may like

User Tag List

Tags for this Thread

Like this thread? Share it with others

Like this thread? Share it with others

Posting Permissions

  • You may not post new threads
  • You may not post replies
  • You may not post attachments
  • You may not edit your posts
  •