Unique pairs from a single column (VBA)

[caybrew]

Hi all, I have multiple columns (A-C) of data that I am looking to analyze and group in unique pairs before outputting the pairs to new columns. All I need is unique groups of 2.

I found this awesome code from @Eric W but I cant seem to figure out how to make it loop through all my columns. It only works on the first column. Any ideas? Any help is much appreciated!

Sub Subsets()
Dim MyNames As Variant, OutCell As Range, MyDic As Object, i As Long

    MyNames = Range(Range("A2"), Range("A2").End(xlDown)).Value
    Set OutCell = Range("C1")
    
    For i = 1 To UBound(MyNames)
        Set MyDic = CreateObject("Scripting.Dictionary")
        MyDic(0) = "Sets of " & i
        Call RecurSubs(MyNames, i, 0, 0, "", MyDic)
        OutCell.Offset(, i - 1).Resize(MyDic.Count).Value = WorksheetFunction.Transpose(MyDic.items)
        Set MyDic = Nothing
    Next i
    
End Sub

Sub RecurSubs(ByRef MyNames, ByRef MaxLevel, ByVal CurLevel, ByVal ix, ByVal str1, ByRef MyDic)
Dim i As Long

    If CurLevel = MaxLevel Then
        MyDic(MyDic.Count) = Left(str1, Len(str1) - 2)
        Exit Sub
    End If
    
    For i = ix + 1 To UBound(MyNames)
        Call RecurSubs(MyNames, MaxLevel, CurLevel + 1, i, str1 & MyNames(i, 1) & ", ", MyDic)
    Next i
    
End Sub

 

[StephenCrump]

Welcome to the Forum!

The answer depends on what you mean by etc etc, which is not clear.

I think you want this:

	A	B	C	D	E	F	G
1	Input
2	Dog	Pig	Snake		Dog, Cat	Pig, Cow	Snake, Spider
3	Cat	Cow	Spider		Dog, Moose	Pig, Horse	Snake, Bird
4	Moose	Horse	Bird		Dog, Rat	Pig, Sheep	Snake, Mouse
5	Rat	Sheep	Mouse		Cat, Moose	Cow, Horse	Spider, Bird
6					Cat, Rat	Cow, Sheep	Spider, Mouse
7					Moose, Rat	Horse, Sheep	Bird, Mouse
Sheet1

which you can get with just a couple of quick changes to @Eric W's code:

Sub Subsets()
    
    Dim MyNames As Variant, OutCell As Range, MyDic As Object, i As Long, j As Long

    For j = 1 To 3
        MyNames = Range(Range("A2").Offset(, j - 1), Range("A2").Offset(, j - 1).End(xlDown)).Value
        Set OutCell = Range("D2").Offset(, j - 1)
        
        For i = 2 To 2
            Set MyDic = CreateObject("Scripting.Dictionary")
            Call RecurSubs(MyNames, i, 0, 0, "", MyDic)
            OutCell.Offset(, i - 1).Resize(MyDic.Count).Value = WorksheetFunction.Transpose(MyDic.items)
            Set MyDic = Nothing
        Next i
    Next j

End Sub

But perhaps you want all 216 permutations?

	A	B	C	D	E	F	G
1	Input
2	Dog	Pig	Snake		Dog, Cat	Pig, Cow	Snake, Spider
3	Cat	Cow	Spider		Dog, Cat	Pig, Cow	Snake, Bird
4	Moose	Horse	Bird		Dog, Cat	Pig, Cow	Snake, Mouse
5	Rat	Sheep	Mouse		Dog, Cat	Pig, Cow	Spider, Bird
6					Dog, Cat	Pig, Cow	Spider, Mouse
7					Dog, Cat	Pig, Cow	Bird, Mouse
8					Dog, Cat	Pig, Horse	Snake, Spider
9					Dog, Cat	Pig, Horse	Snake, Bird
10					Dog, Cat	Pig, Horse	Snake, Mouse
11					Dog, Cat	Pig, Horse	Spider, Bird
12					Dog, Cat	Pig, Horse	Spider, Mouse
13					Dog, Cat	Pig, Horse	Bird, Mouse
14					Dog, Cat	Pig, Sheep	Snake, Spider
15					Dog, Cat	Pig, Sheep	Snake, Bird
16					etc
Sheet1

 

[caybrew]

This worked perfect! Thanks so much for your help.

 

[StephenCrump]

You're welcome. I'm glad it works for you.