Reply
 
LinkBack Thread Tools Search this Thread Display Modes
  #1   Report Post  
Old January 13th 05, 06:53 PM posted to microsoft.public.excel.programming
external usenet poster
 
First recorded activity by ExcelBanter: Jan 2005
Posts: 3
Default Combinations

Following is a macro based solution form Myrna Larson (Microsoft MVP) on
permutation and combinations

1. It allows Combinations or Permutations (see note below).
2. The macro handles numbers, text strings, words (e.g. names of people) or
symbols.
3. The combinations are written to a new sheet.
4. Results are returned almost instantaneously.

Setup:
In sheet1:
Cell A1, put “C” (Combinations) or “P” (Permutations).
Cell A2, put the number of items in the subset – in my case it’s 3.
Cells A3 down, your list. - in my case (numbers from 1-5)

My question is:
================

What changes do I need to make to this VBA code to get multiple combinations
in just one go. Example:

If I have C in A1, 3 in A2 and Numbers from 1-5 in the range A3:A7 and if I
run the macro, it will give me all possible combinations of 3 in sheet2

If I have two conditions

1. If I have C in A1, 3 in A2 and Numbers from 1-5 in the range A3:A7 and if
I run the macro, it will give me all possible combinations of 3 in sheet2

2. Lets say if I have C in B1, 3 in B2 and Numbers from 1-5 in the range
B3:B7 and if I run the macro, it should give me all possible combinations of
3 in sheet2 in columns A and B

== AND ==

Is it possible to put the output of the below given VBA code in ACCESS table
in just one field instead of Sheet2 of the same worksheet?

I have 21 names and I want to make a group of 7 people which totals up to
116280 (=COMBIN(21,7)). Instead of having 65536 names in column A of Sheet2
and 50744 names in column B of Sheet2, I want to put the entire 116280 names
in an ACCESS Table in just one field.

Maxi
====

HERE IS THE CODE:

Option Explicit
Dim vAllItems As Variant
Dim Buffer() As String
Dim BufferPtr As Long
Dim Results As Worksheet
'
' Myrna Larson, July 25, 2000, Microsoft.Public.Excel.Misc

Sub ListPermutationsOrCombinations()
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

Worksheets("Sheet1").Range("A1").Select
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

  #2   Report Post  
Old January 13th 05, 09:39 PM posted to microsoft.public.excel.programming
external usenet poster
 
First recorded activity by ExcelBanter: Oct 2007
Posts: 863
Default Combinations

The macro is written to expect all of the members of the population in a
single column, starting with the 3rd cell. What's the problem with copying the
data from B3:B7 over to A8?

As for sending the data to Access, AIR, you can do 2 imports from Excel to
Access. (You may have to copy the 2nd column onto a 2nd worksheet.) It's
possible to modify the macro to send the data to Access directly, but I can't
see that it's worth my time to do it, particularly if this is a "one-time"
need. Of course you are free to modify the macro as you wish.

In fact, you could modify the code to run from Access, where the population
members are in a table instead of on a worksheet, and the combinations are
added to a new table.

BTW, FWIW, it doesn't run "instantaneously" when the numbers of combinations
or permutations is large <g.

On Thu, 13 Jan 2005 10:53:02 -0800, "mac_see"
wrote:

Following is a macro based solution form Myrna Larson (Microsoft MVP) on
permutation and combinations

1. It allows Combinations or Permutations (see note below).
2. The macro handles numbers, text strings, words (e.g. names of people) or
symbols.
3. The combinations are written to a new sheet.
4. Results are returned almost instantaneously.

Setup:
In sheet1:
Cell A1, put C (Combinations) or P (Permutations).
Cell A2, put the number of items in the subset in my case its 3.
Cells A3 down, your list. - in my case (numbers from 1-5)

My question is:
================

What changes do I need to make to this VBA code to get multiple combinations
in just one go. Example:

If I have C in A1, 3 in A2 and Numbers from 1-5 in the range A3:A7 and if I
run the macro, it will give me all possible combinations of 3 in sheet2

If I have two conditions

1. If I have C in A1, 3 in A2 and Numbers from 1-5 in the range A3:A7 and if
I run the macro, it will give me all possible combinations of 3 in sheet2

2. Lets say if I have C in B1, 3 in B2 and Numbers from 1-5 in the range
B3:B7 and if I run the macro, it should give me all possible combinations of
3 in sheet2 in columns A and B

== AND ==

Is it possible to put the output of the below given VBA code in ACCESS table
in just one field instead of Sheet2 of the same worksheet?

I have 21 names and I want to make a group of 7 people which totals up to
116280 (=COMBIN(21,7)). Instead of having 65536 names in column A of Sheet2
and 50744 names in column B of Sheet2, I want to put the entire 116280 names
in an ACCESS Table in just one field.

Maxi
====

HERE IS THE CODE:

Option Explicit
Dim vAllItems As Variant
Dim Buffer() As String
Dim BufferPtr As Long
Dim Results As Worksheet
'
' Myrna Larson, July 25, 2000, Microsoft.Public.Excel.Misc

Sub ListPermutationsOrCombinations()
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

Worksheets("Sheet1").Range("A1").Select
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


  #3   Report Post  
Old January 14th 05, 04:11 PM posted to microsoft.public.excel.programming
external usenet poster
 
First recorded activity by ExcelBanter: Jan 2005
Posts: 3
Default Combinations

Thank you for your reply.

I can copy the data from B3:B7 over to A8. I just asked that question out of
curiousity. I can even export the data to ACCESS.

I am not an expert in VBA, if you could please modify the code to either
send the data to Access directly, OR if you could modify the code to run from
Access that would be wonderful.

Believe me its not a "one-time" job. I do all my work in ACCESS. Please
modify the code and send it to me.


Maxi

"Myrna Larson" wrote:

The macro is written to expect all of the members of the population in a
single column, starting with the 3rd cell. What's the problem with copying the
data from B3:B7 over to A8?

As for sending the data to Access, AIR, you can do 2 imports from Excel to
Access. (You may have to copy the 2nd column onto a 2nd worksheet.) It's
possible to modify the macro to send the data to Access directly, but I can't
see that it's worth my time to do it, particularly if this is a "one-time"
need. Of course you are free to modify the macro as you wish.

In fact, you could modify the code to run from Access, where the population
members are in a table instead of on a worksheet, and the combinations are
added to a new table.

BTW, FWIW, it doesn't run "instantaneously" when the numbers of combinations
or permutations is large <g.

On Thu, 13 Jan 2005 10:53:02 -0800, "mac_see"
wrote:

Following is a macro based solution form Myrna Larson (Microsoft MVP) on
permutation and combinations

1. It allows Combinations or Permutations (see note below).
2. The macro handles numbers, text strings, words (e.g. names of people) or
symbols.
3. The combinations are written to a new sheet.
4. Results are returned almost instantaneously.

Setup:
In sheet1:
Cell A1, put “C” (Combinations) or “P” (Permutations).
Cell A2, put the number of items in the subset – in my case it’s 3.
Cells A3 down, your list. - in my case (numbers from 1-5)

My question is:
================

What changes do I need to make to this VBA code to get multiple combinations
in just one go. Example:

If I have C in A1, 3 in A2 and Numbers from 1-5 in the range A3:A7 and if I
run the macro, it will give me all possible combinations of 3 in sheet2

If I have two conditions

1. If I have C in A1, 3 in A2 and Numbers from 1-5 in the range A3:A7 and if
I run the macro, it will give me all possible combinations of 3 in sheet2

2. Lets say if I have C in B1, 3 in B2 and Numbers from 1-5 in the range
B3:B7 and if I run the macro, it should give me all possible combinations of
3 in sheet2 in columns A and B

== AND ==

Is it possible to put the output of the below given VBA code in ACCESS table
in just one field instead of Sheet2 of the same worksheet?

I have 21 names and I want to make a group of 7 people which totals up to
116280 (=COMBIN(21,7)). Instead of having 65536 names in column A of Sheet2
and 50744 names in column B of Sheet2, I want to put the entire 116280 names
in an ACCESS Table in just one field.

Maxi
====

HERE IS THE CODE:

Option Explicit
Dim vAllItems As Variant
Dim Buffer() As String
Dim BufferPtr As Long
Dim Results As Worksheet
'
' Myrna Larson, July 25, 2000, Microsoft.Public.Excel.Misc

Sub ListPermutationsOrCombinations()
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

Worksheets("Sheet1").Range("A1").Select
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



  #4   Report Post  
Old January 14th 05, 06:06 PM posted to microsoft.public.excel.programming
external usenet poster
 
First recorded activity by ExcelBanter: Oct 2007
Posts: 863
Default Combinations

Sorry, but Access is not my "native tongue". It would take me several hours to
do this in Access.

Perhaps you can find an Access or Excel consultant to do it for you. Chip
Pearson does Excel projects; I don't know whether he does Access too, or what
his rates are.


On Fri, 14 Jan 2005 08:11:04 -0800, "mac_see"
wrote:

Thank you for your reply.

I can copy the data from B3:B7 over to A8. I just asked that question out of
curiousity. I can even export the data to ACCESS.

I am not an expert in VBA, if you could please modify the code to either
send the data to Access directly, OR if you could modify the code to run from
Access that would be wonderful.

Believe me its not a "one-time" job. I do all my work in ACCESS. Please
modify the code and send it to me.


Maxi

"Myrna Larson" wrote:

The macro is written to expect all of the members of the population in a
single column, starting with the 3rd cell. What's the problem with copying

the
data from B3:B7 over to A8?

As for sending the data to Access, AIR, you can do 2 imports from Excel to
Access. (You may have to copy the 2nd column onto a 2nd worksheet.) It's
possible to modify the macro to send the data to Access directly, but I

can't
see that it's worth my time to do it, particularly if this is a "one-time"
need. Of course you are free to modify the macro as you wish.

In fact, you could modify the code to run from Access, where the population
members are in a table instead of on a worksheet, and the combinations are
added to a new table.

BTW, FWIW, it doesn't run "instantaneously" when the numbers of

combinations
or permutations is large <g.

On Thu, 13 Jan 2005 10:53:02 -0800, "mac_see"
wrote:

Following is a macro based solution form Myrna Larson (Microsoft MVP) on
permutation and combinations

1. It allows Combinations or Permutations (see note below).
2. The macro handles numbers, text strings, words (e.g. names of people)

or
symbols.
3. The combinations are written to a new sheet.
4. Results are returned almost instantaneously.

Setup:
In sheet1:
Cell A1, put C (Combinations) or P (Permutations).
Cell A2, put the number of items in the subset in my case its 3.
Cells A3 down, your list. - in my case (numbers from 1-5)

My question is:
================

What changes do I need to make to this VBA code to get multiple

combinations
in just one go. Example:

If I have C in A1, 3 in A2 and Numbers from 1-5 in the range A3:A7 and if

I
run the macro, it will give me all possible combinations of 3 in sheet2

If I have two conditions

1. If I have C in A1, 3 in A2 and Numbers from 1-5 in the range A3:A7 and

if
I run the macro, it will give me all possible combinations of 3 in sheet2

2. Lets say if I have C in B1, 3 in B2 and Numbers from 1-5 in the range
B3:B7 and if I run the macro, it should give me all possible combinations

of
3 in sheet2 in columns A and B

== AND ==

Is it possible to put the output of the below given VBA code in ACCESS

table
in just one field instead of Sheet2 of the same worksheet?

I have 21 names and I want to make a group of 7 people which totals up to
116280 (=COMBIN(21,7)). Instead of having 65536 names in column A of

Sheet2
and 50744 names in column B of Sheet2, I want to put the entire 116280

names
in an ACCESS Table in just one field.

Maxi
====

HERE IS THE CODE:

Option Explicit
Dim vAllItems As Variant
Dim Buffer() As String
Dim BufferPtr As Long
Dim Results As Worksheet
'
' Myrna Larson, July 25, 2000, Microsoft.Public.Excel.Misc

Sub ListPermutationsOrCombinations()
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

Worksheets("Sheet1").Range("A1").Select
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




  #5   Report Post  
Old February 3rd 05, 06:59 PM posted to microsoft.public.excel.programming
external usenet poster
 
First recorded activity by ExcelBanter: Jul 2006
Posts: 27,285
Default Combinations

You would get that error if you didn't copy all the code. Her code runs
fine.

You need all this: (like they on eletrical appliances - no user serviceable
parts contained herein).


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

--
Regards,
Tom Ogilvy






wrote in message
ups.com...
Hi Myrna,

I Tried Running your Code for Combinations, But Kept Getting an Error
on the Line :-

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

It Says "Expected Sub, Function or Property".
I Tried to Dim it Along with Several Other Ideas, But to NO Avail.
Would you be Able to have a Look at the Problem Please.

Thanks in Advance.
All the Best
Paul





Reply
Thread Tools Search this Thread
Search this Thread:

Advanced Search
Display Modes

Posting Rules

Smilies are On
[IMG] code is On
HTML code is Off
Trackbacks are On
Pingbacks are On
Refbacks are On


Similar Threads
Thread Thread Starter Forum Replies Last Post
Combinations Balaji Excel Worksheet Functions 5 October 28th 07 03:22 PM
combinations Sonny Excel Discussion (Misc queries) 11 August 26th 07 08:26 PM
Combinations Chris_t_2k5 Excel Discussion (Misc queries) 2 February 7th 06 10:36 AM
Possible Combinations Please HELP!!! Excel Discussion (Misc queries) 1 January 6th 06 03:58 PM
getting combinations vecky New Users to Excel 1 January 1st 06 12:37 AM


All times are GMT +1. The time now is 11:41 PM.

Powered by vBulletin® Copyright ©2000 - 2021, Jelsoft Enterprises Ltd.
Copyright 2004-2021 ExcelBanter.
The comments are property of their posters.
 

About Us

"It's about Microsoft Excel"

 

Copyright © 2017