list all unique combinations from list

[palaeontology]

I have the following dynamic list (and yes, the list can sometimes [like in this example] have some blank entries at the beginning) ...

Is there a way (either through formula or vb code .. I'm trying to avoid the need for the user to click a series of ribbon options, etc) to return a list of all possible unique combinations of letters from that list ?

For example, the unique combinations for the list above would be ....

BK
BO
KO

Note: I don't want BB, KK or OO to be returned.

Here's another example ...

This list should yield the following unique combinations ...

RG
RA
RF
RJ
GA
GF
GJ
AF
AJ
FJ

I've tried to set up a matrix solution, but not sure how to do that in excel, or even if that will return the result that I need.

I know that the number of unique combinations follows Pascal's Triangle. So ...
2 letters will have 1 possible combination
3 letters will have 3 possible combination
4 letters will have 6 possible combination
5 letters will have 10 possible combination
etc

but not sure how to use that knowledge in deriving a solution.

Any assistance would be greatly appreciated.

Very kind regards,

Chris

 

[maabadi]

if your data is in Column A Try this (you see result at column C):

Sub Test()
Dim Lr As Long, M As String, N As String, K As Long, i As Long, j As Long, A As Long, B As Long
Lr = Range("A" & Rows.Count).End(xlUp).Row
M = Replace(Replace(Replace(Join(Application.Transpose(Range("A2:A" & Lr).Value), ","), ",,,,", ","), ",,,", ","), ",,", ",")
If Left(M, 1) = "," Then M = Right(M, Len(M) - 1)
K = Len(M) - Len(Replace(M, ",", "")) + 1
For i = 1 To K - 1
A = InStr(i * 2 - 1, M, ",") - 1
For j = 2 To K
B = InStr(j * 2 - 1, M, ",") - 1
If B < 0 Then B = Len(M)
If B > A Then
N = N & "," & Mid(M, A, 1) & Mid(M, B, 1)
End If
Next j
Next i
N = Right(N, Len(N) - 1)
Range("C2").Resize(K * (K - 1) / 2).Value = Application.Transpose(Split(N, ","))
End Sub

 

[palaeontology]

if your data is in Column A Try this (you see result at column C):

Sub Test()
Dim Lr As Long, M As String, N As String, K As Long, i As Long, j As Long, A As Long, B As Long
Lr = Range("A" & Rows.Count).End(xlUp).Row
M = Replace(Replace(Replace(Join(Application.Transpose(Range("A2:A" & Lr).Value), ","), ",,,,", ","), ",,,", ","), ",,", ",")
If Left(M, 1) = "," Then M = Right(M, Len(M) - 1)
K = Len(M) - Len(Replace(M, ",", "")) + 1
For i = 1 To K - 1
A = InStr(i * 2 - 1, M, ",") - 1
For j = 2 To K
B = InStr(j * 2 - 1, M, ",") - 1
If B < 0 Then B = Len(M)
If B > A Then
N = N & "," & Mid(M, A, 1) & Mid(M, B, 1)
End If
Next j
Next i
N = Right(N, Len(N) - 1)
Range("C2").Resize(K * (K - 1) / 2).Value = Application.Transpose(Split(N, ","))
End Sub

Thankyou, so much, for your excellent and speedy response.

Your code works perfectly !!!

I am truly appreciative, thankyou so much.

Very kind regards,

Chris

 

[palaeontology]

Hi again,

I just noticed that it didn't return the FJ combination .... there should be an FJ and an F at the very bottom.

I tried this shorter lists of 3, and 4 letters, and each of those gave the full list of expected combinations, but it seems to have struggled with lists of 5 or more letters to juggle.

I actually have more than just the one column of this .. I have 26 columns ... admittedly, most won't have any letters in them, but I need to cater for the possibility they might.
The columns to be examined are in the range BU6:CT31 ...

Is it possible to alter the code to account for the fact there are 26 columns that each, individually, need to be looked at AND return the results below the 26 columns, starting in row 35 (as in the image below) ....

I'll try to alter your code myself, but while I can read vba (and understand most of what it says) I have no ability to write it.

I really do apologise for this,

very kind regards,

Chris

 

[Peter_SSs]

Another approach that you could consider.

Sub All2Combos()
  Dim a As Variant, b As Variant
  Dim i As Long, j As Long, x As Long, y As Long
  
  a = Range("A2", Range("A" & Rows.Count).End(xlUp)).Value
  ReDim b(1 To UBound(a))
  For i = 1 To UBound(a)
    If Len(a(i, 1)) > 0 Then
      x = x + 1: b(x) = a(i, 1)
    End If
  Next i
  ReDim a(1 To WorksheetFunction.Combin(x, 2), 1 To 1)
  For i = 1 To x - 1
    For j = i + 1 To x
      y = y + 1: a(y, 1) = b(i) & b(j)
    Next j
  Next i
  Range("C2").Resize(y).Value = a
End Sub

 

[palaeontology]

Hi Peter,

thankyou for piecing together some code. I really do appreciate it.

As I have 26 columns of these lists, and each column needs its own analysis, I copied your code 25 times to give each column its own code. I changed the 3 necessary bits to read which column it was coming from, as well as where I need it to return the results. For example, the code I use for analysing column BU6:BU31 is ...

Sub All2Combos1st()
  Dim a As Variant, b As Variant
  Dim i As Long, j As Long, x As Long, y As Long
  
  a = Range("bu6", Range("bu" & Rows.Count).End(xlUp)).Value
  ReDim b(1 To UBound(a))
  For i = 1 To UBound(a)
    If Len(a(i, 1)) > 0 Then
      x = x + 1: b(x) = a(i, 1)
    End If
  Next i
  ReDim a(1 To WorksheetFunction.Combin(x, 2), 1 To 1)
  For i = 1 To x - 1
    For j = i + 1 To x
      y = y + 1: a(y, 1) = b(i) & b(j)
    Next j
  Next i
  Range("cv6").Resize(y).Value = a
End Sub

So in the image below you can see the original 26 columns (on the left) and on the right you can see the resultant 26 columns that hold the corresponding unique combinations that your code returns.

However, the code returns an error when trying to read a column that has no letters, for example, columns BV, BX, BZ, CA, CB, CC, etc etc etc.

This is the error message ..

Am I doing something wrong ?

Kind regards,

Chris

 

[Peter_SSs]

As I have 26 columns

Ah, I had missed post #4 while I was composing mine.

Should be no need to copy the code 26 times. Try this version

Sub All2Combos_v2()
  Dim a As Variant, b As Variant
  Dim i As Long, j As Long, x As Long, y As Long, col As Long, lr As Long
  
  For col = 73 To 98 '<- Columns BU to CT
    lr = Cells(35, col).End(xlUp).Row
    If lr > 5 Then
      a = Range(Cells(6, col), Cells(lr, col)).Value
      ReDim b(1 To UBound(a))
      x = 0
      For i = 1 To UBound(a)
        If Len(a(i, 1)) > 0 Then
          x = x + 1: b(x) = a(i, 1)
        End If
      Next i
      ReDim a(1 To WorksheetFunction.Combin(x, 2), 1 To 1)
      y = 0
      For i = 1 To x - 1
        For j = i + 1 To x
          y = y + 1: a(y, 1) = b(i) & b(j)
        Next j
      Next i
      Cells(35, col).Resize(y).Value = a
    End If
  Next col
End Sub

 

[palaeontology]

Hi again Peter,

unfortunately your new code is again returning a 1004 run-time error whenever it meets a column range that is devoid of any letters.

For example ...

In the above example, It gets to the 4th column ... the one in column BX ... and because BX6:BX31 is devoid of any letters, it returns the run-time error.

I know it's definitely the empty column ranges it struggles with, because I've experimented with where I had the first empty column range, and it always returns correct combinations (from left to right) up to the first empty column range, and then goes no further, returning the run-time error.

Very kind regards,

Chris

 

[Peter_SSs]

Works fine for me with empty columns ..

I know it's definitely the empty column ranges

... but it fails if those empty columns are actually full (of null strings from formulas?)

It would also fail if there was only one non-null value in the column. Try this one.

Sub All2Combos_v3()
  Dim a As Variant, b As Variant
  Dim i As Long, j As Long, x As Long, y As Long, col As Long, lr As Long
  
  For col = 73 To 98 '<- Columns BU to CT
    lr = Cells(35, col).End(xlUp).Row
    If lr > 5 Then
      a = Range(Cells(6, col), Cells(lr, col)).Value
      ReDim b(1 To UBound(a))
      x = 0
      For i = 1 To UBound(a)
        If Len(a(i, 1)) > 0 Then
          x = x + 1: b(x) = a(i, 1)
        End If
      Next i
      If x > 1 Then
        ReDim a(1 To WorksheetFunction.Combin(x, 2), 1 To 1)
        y = 0
        For i = 1 To x - 1
          For j = i + 1 To x
            y = y + 1: a(y, 1) = b(i) & b(j)
          Next j
        Next i
        Cells(35, col).Resize(y).Value = a
      End If
    End If
  Next col
End Sub

 

[palaeontology]

That did the trick ... thankyou so much.

Yes, I had neglected to let you know that the letters in those ranges were the result of formulae.

Again, thankyou so much.

Very kindest regards,

Chris