Google Groups no longer supports new Usenet posts or subscriptions. Historical content remains viewable.

Dismiss

1,620 views

Skip to first unread message

Jan 18, 2003, 9:08:57 AM1/18/03

to

Hi!

I am trying to think how VBA/Excel could list all possible combinations /

arrangements of a set of elements, but I couldn´t manage it yet.

I think Myrna Larson had written some code for this, and that it was posted

in this newsgroup.

Notice that i am not talking about permutations, but combinations of a

(smaller) number of elements from a set.

Any one can do this?

Tham you very much,

--

João Veríssimo (joao_ve...@clix.pt)

Jan 18, 2003, 9:22:59 AM1/18/03

to

Myrna's code you want, Myrna's code you got!!

Written and Posted by Myrna Larson:

Option Explicit

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

--

Regards

Ken....................... Win XP / XL2K & XLXP

----------------------------------------------------------------------------

Public Service Request - It is very much appreciated

in text-only groups if you don't attach files - Thanks

----------------------------------------------------------------------------

"João Veríssimo" <joao_ve...@clix.pt> wrote in message

news:MfdW9.1812$9x.11...@newsserver.ip.pt...

Feb 8, 2016, 7:07:06 AM2/8/16

to

i am doing project in vba.

i want to known how to create a combinations using text/words like aaa,bbb and numbers?

can u help me?

\

Jun 3, 2020, 6:05:05 AM6/3/20

to

Thank you very much everyone - Myrna Larson especially.

0 new messages

Search

Clear search

Close search

Google apps

Main menu