Hi all,
instead of reenventing the wheel I turn to this group with my case:
assume a single column consisting of 20 cells; now, 11 cells contain the
number 1, others are empty. What I'm looking for is an elegant way of
elaborating all possible combinations of these 11 pieces as how they can be
scattered throughout 20 empty cells. Mind you, this could be done by hand
(ahhhhh), but a few combinations could be ommitted simply by mistake, and to
accomplish this would be a real drudgery; that's why I'm looking for an
algorithm to have this done for me. Any ideas?
Mac.

Mac,

There are

=COMBIN(20,11)

or

167,960

different ways to group 20 item 11 at a time.

> Mind you, this could be done by hand (ahhhhh),

Sure, if you have a lot of time on your hands....

Better would be to explain what you are trying to do - perhaps you could randomly select 11 items
out of the 20?

If you really want an algorithm, see below.

HTH,
Bernie
MS Excel MVP


Here is some wonderful code from Myrna Larsen.

Follow the directions at the top, and you're good to go.

'>Maybe, Myrna will post the entire functioning code module
'
'Since you asked, here it is. It is generic, i.e. it isn't written specifically
'for a given population and set size, as yours it. It will do permutations or
'combinations. It uses a recursive routine to generate the subsets, one routine
'for combinations, a different one for permutations.
'
'To use it, you put the letter C or P (for combinations or permutations) in a
'cell. The cell below that contains the number of items in a subset. The cells
'below are a list of the items that make up the population. They could be
'numbers, letters and symbols, or words, etc.
'
'You select the top cell, or the entire range and run the sub. The subsets are
'written to a new sheet in the workbook.


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



"Mac" <(E-Mail Removed)> wrote in message
news:32179E0C-6ECC-475B-8653-(E-Mail Removed)...
> Hi all,
> instead of reenventing the wheel I turn to this group with my case:
> assume a single column consisting of 20 cells; now, 11 cells contain the
> number 1, others are empty. What I'm looking for is an elegant way of
> elaborating all possible combinations of these 11 pieces as how they can be
> scattered throughout 20 empty cells. Mind you, this could be done by hand
> (ahhhhh), but a few combinations could be ommitted simply by mistake, and to
> accomplish this would be a real drudgery; that's why I'm looking for an
> algorithm to have this done for me. Any ideas?
> Mac.

And if you want to know what the 167,960 combinations are have a look in your
other thread and stick to a single thread.

Mike

"Mac" wrote:

> Hi all,
> instead of reenventing the wheel I turn to this group with my case:
> assume a single column consisting of 20 cells; now, 11 cells contain the
> number 1, others are empty. What I'm looking for is an elegant way of
> elaborating all possible combinations of these 11 pieces as how they can be
> scattered throughout 20 empty cells. Mind you, this could be done by hand
> (ahhhhh), but a few combinations could be ommitted simply by mistake, and to
> accomplish this would be a real drudgery; that's why I'm looking for an
> algorithm to have this done for me. Any ideas?
> Mac.

> .. elaborating ..
'msgbox' probably isn't what you want, but you can
change that:

Const gN = 20, gK = 11

Sub Main()
Call Recurse(0, 1, "") ' level, start, string
End Sub

Sub Recurse(pLevel%, pStart%, pStr$)
Dim i1%
If pLevel = gK Then ' got gN items
MsgBox pStr
Exit Sub
End If
For i1 = pStart To gN + gK - pLevel - 1
Call Recurse(pLevel + 1, i1 + 1, pStr & i1 & " ")
Next i1
End Sub ' Dave D-C

Mac <(E-Mail Removed)> wrote:
>Hi all,
>instead of reenventing the wheel I turn to this group with my case:
>assume a single column consisting of 20 cells; now, 11 cells contain the
>number 1, others are empty. What I'm looking for is an elegant way of
>elaborating all possible combinations of these 11 pieces as how they can be
>scattered throughout 20 empty cells. Mind you, this could be done by hand
>(ahhhhh), but a few combinations could be ommitted simply by mistake, and to
>accomplish this would be a real drudgery; that's why I'm looking for an
>algorithm to have this done for me. Any ideas?
>Mac.


----== Posted via Pronews.Com - Unlimited-Unrestricted-Secure Usenet News==----
http://www.pronews.com The #1 Newsgroup Service in the World! >100,000 Newsgroups
---= - Total Privacy via Encryption =---