All Combinations No Duplicates Macro

[april_adams5]

Hi,

I have been using a macro I found in the forums (written by pbornemeier) to generate all possible combinations from multiple columns and remove duplicates having the same value in the same row. Is it possible to add functionality that would also remove row duplicates where the values are just in a different order?

Below is an example. The top is the current output, and the bottom is the desired output.

Apple	Apple		Apple	Pear
Pear	Pear		Apple	Peach
Peach	Peach		Pear	Apple
			Pear	Peach
			Peach	Apple
			Peach	Pear
Apple	Apple		Apple	Pear
Pear	Pear		Apple	Peach
Peach	Peach		Pear	Peach

Here is pbornemeier’s 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

Any help would be great!

Thanks

April

 

[andrew_milonavic]

@april_adams5

I would like the same thing. I was hoping for a formula, but I don’t think a formula is ideal anymore. Hopefully someone can help us both.

Andrew