I need to generate a list of combinations

[ciprianb]

Hello! I need some help from you. Please help me to generate a list of numbers of this function in Excel: COMBIN(20,3), but i want the combinations of numbers. I want to creat a list of 20 questions and every question has 3 answer. I think that are 1140 combinations. I'm right? I am a newbie and not so advanced in excel. Thank you!

 

[VoG]

Hi. See if this helps http://www.mrexcel.com/forum/showthread.php?t=379323

 

[ciprianb]

thanks, but i don't understand much of how i have to do. Maybe it's simple but not for me.

 

[ciprianb]

Someone just told me about a software combinations.exe, but i don't find that.

 

[VoG]

Press ALT + F11 to open the Visual Basic Editor, select Module from the Insert menu and paste into the white space on the right

Dim vAllItems As Variant
Dim Buffer() As String
Dim BufferPtr As Long
Dim Results As Worksheet
'
'  Posted by Myrna Larson
'  July 25, 2000
'  Microsoft.Public.Excel.Misc
'  Subject:  Combin
'
'
'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.
'
'
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

Press ALT + Q to close the code window.

In A1 enter the letter C

In A2 enter the number of items

In A3 and below list all your items

Click in A1, press ALT + F8, click on ListPermutations then click the Run button.

 

[ciprianb]

New things for me. I done that but it give's me "COMPILE ERROR. Expected: end of statement" and Visual Basic is opening again with this message:



im vAllItems As Variant
Dim Buffer() As String
Dim BufferPtr As Long
Dim Results As Worksheet
'
' Posted by Myrna Larson
' July 25, 2000
' Microsoft.Public.Excel.Misc
' Subject: Combin
'
'
'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.
'
'
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

I did something wrong?

 

[VoG]

You seem to be missing the D in the first line

Dim vAllItems As Variant

 

[ciprianb]

It's working! Thank you. The problem is that something i don't know, because i didn't find my problem. I have a set o 20 questions, with a,b, c, the answers. I can generate the list, and one of the list be the right one. A question has one corect answer. How to put the items in sheet? Sorry if i disturb you so much.

 

[ciprianb]

It is the posibility that every question to have a, b or c as answer. It is okay COMBIN(20,3) function in excel?

 

[Rana80]

Hi,

Thank you for the help with that vba code. It was really useful. But right now I am in need of a code that will do the exact same thing but will consolidate all the outputs in a single worksheet instead of giving the output in multiple worksheets. I would really appreciate your kind help on this.

Thanks and regards,
Rana