Excel - Generate all possible sets of strings 1

[AngO]

Hello All,
I would like some help to generate ALL the possible combinations of 22 strings in combinations of 3 items per set. This is NOT a Permutation or a Combination. (PS - any help on the proper name of what I am trying to do would probably help also!!)

For example:
22 items in sets of 3 (sample: ab, ab1, ab2 . . .ab21)
= 1540 Combinations (order doesn't matter)
= 9240 Permuations (order does matter)
= 10648 what I need (22 to the power of 3)

The following code will give me either the combinations or the permutations - now I want to add the products/multiplication option to the list.

Thanks for any insight you can share!!
AngO

Option Explicit

Dim vAllItems As Variant
Dim Buffer() As String
Dim BufferPtr As Long
Dim Results As Worksheet

Sub ListPermutations()
Dim Rng As Range
Dim PopSize As Integer
Dim SetSize As Integer
Dim Which As String
Dim N As Double
Const BufferSize As Long = 4096

Set Rng = Selection.Columns(1).Cells
If Rng.Cells.Count = 1 Then
Set Rng = Range(Rng, Rng.End(xlDown))
End If

PopSize = Rng.Cells.Count - 2
If PopSize < 2 Then GoTo DataError

SetSize = Rng.Cells(2).Value
If SetSize > PopSize Then GoTo DataError

Which = UCase$(Rng.Cells(1).Value)
Select Case Which
Case "C"
N = Application.WorksheetFunction.Combin(PopSize, SetSize)
Case "P"
N = Application.WorksheetFunction.Permut(PopSize, SetSize)
Case Else
GoTo DataError
End Select
If N > Cells.Count Then GoTo DataError

Application.ScreenUpdating = False

Set Results = Worksheets.Add

vAllItems = Rng.Offset(2, 0).Resize(PopSize).Value
ReDim Buffer(1 To BufferSize) As String
BufferPtr = 0

If Which = "C" Then
AddCombination PopSize, SetSize
Else
AddPermutation PopSize, SetSize
End If
vAllItems = 0

Application.ScreenUpdating = True
Exit Sub

DataError:
If N = 0 Then
Which = "Enter your data in a vertical" & _
" range of at least 4 cells. " _
& String$(2, 10) _
& "Top cell must contain the letter C or P" & _
", 2nd cell is the number" _
& "of items in a subset, the cells" & _
" below are the values from which" _
& "the subset is to be chosen."

Else
Which = "This requires " & Format$(N, "#,##0") & _
" cells, more than are available on the worksheet!"
End If
MsgBox Which, vbOKOnly, "DATA ERROR"
Exit Sub
End Sub

Private Sub AddPermutation(Optional PopSize As Integer = 0, _
Optional SetSize As Integer = 0, _
Optional NextMember As Integer = 0)

Static iPopSize As Integer
Static iSetSize As Integer
Static SetMembers() As Integer
Static Used() As Integer
Dim i As Integer

If PopSize <> 0 Then
iPopSize = PopSize
iSetSize = SetSize
ReDim SetMembers(1 To iSetSize) As Integer
ReDim Used(1 To iPopSize) As Integer
NextMember = 1
End If

For i = 1 To iPopSize
If Used(i) = 0 Then
SetMembers(NextMember) = i
If NextMember <> iSetSize Then
Used(i) = True
AddPermutation , , NextMember + 1
Used(i) = False
Else
SavePermutation SetMembers()
End If
End If
Next i

If NextMember = 1 Then
SavePermutation SetMembers(), True
Erase SetMembers
Erase Used
End If

End Sub 'AddPermutation

Private Sub AddCombination(Optional PopSize As Integer = 0, _
Optional SetSize As Integer = 0, _
Optional NextMember As Integer = 0, _
Optional NextItem As Integer = 0)

Static iPopSize As Integer
Static iSetSize As Integer
Static SetMembers() As Integer
Dim i As Integer

If PopSize <> 0 Then
iPopSize = PopSize
iSetSize = SetSize
ReDim SetMembers(1 To iSetSize) As Integer
NextMember = 1
NextItem = 1
End If

For i = NextItem To iPopSize
SetMembers(NextMember) = i
If NextMember <> iSetSize Then
AddCombination , , NextMember + 1, i + 1
Else
SavePermutation SetMembers()
End If
Next i

If NextMember = 1 Then
SavePermutation SetMembers(), True
Erase SetMembers
End If

End Sub 'AddCombination

Private Sub SavePermutation(ItemsChosen() As Integer, _
Optional FlushBuffer As Boolean = False)

Dim i As Integer, sValue As String
Static RowNum As Long, ColNum As Long

If RowNum = 0 Then RowNum = 1
If ColNum = 0 Then ColNum = 1

If FlushBuffer = True Or BufferPtr = UBound(Buffer()) Then
If BufferPtr > 0 Then
If (RowNum + BufferPtr - 1) > Rows.Count Then
RowNum = 1
ColNum = ColNum + 1
If ColNum > 256 Then Exit Sub
End If

Results.Cells(RowNum, ColNum).Resize(BufferPtr, 1).Value _
= Application.WorksheetFunction.Transpose(Buffer())
RowNum = RowNum + BufferPtr
End If

BufferPtr = 0
If FlushBuffer = True Then
Erase Buffer
RowNum = 0
ColNum = 0
Exit Sub
Else
ReDim Buffer(1 To UBound(Buffer))
End If

End If

'construct the next set
For i = 1 To UBound(ItemsChosen)
sValue = sValue & ", " & vAllItems(ItemsChosen(i), 1)
Next i

'and save it in the buffer
BufferPtr = BufferPtr + 1
Buffer(BufferPtr) = Mid$(sValue, 3)
End Sub 'SavePermutation

 

[Zathras]

I can't quite figure out what all of that code is doing, but here is a routine that fills 10,648 (A2 thru A10649) rows with 3-string combinations as found in A1 thru V1:

Sub AllCombos()[green]
' Fills A2 thru A10649 with all 3-group combinations of
' the strings found in A1 thru V1[/green]
Dim i As Integer
Dim j As Integer
Dim k As Integer
Dim nRow As Long
  Application.ScreenUpdating = False
  nRow = 2
  For i = 1 To 22
    Application.StatusBar = "i = " & i
    For j = 1 To 22
      For k = 1 To 22
        Cells(nRow, 1).Value = Cells(1, i) & Cells(1, j) & Cells(1, k)
        nRow = nRow + 1
      Next k
    Next j
  Next i
  Application.StatusBar = False
  Application.ScreenUpdating = True
End Sub

If this isn't what you are looking for, then post again with a clear description of what you really need. I'm heading out on a 2-week holiday, so I won't be checking back for a while.

 

[AngO]

Zathras,
Thank you for your wonderful help.
I was working off an old file someone else had created - and was trying to fix what I had rather than start over - which I should have done. Your shorter code will work much better than the old.

Have a nice Vacation!
AngO