Home |
Search |
Today's Posts |
#1
Posted to microsoft.public.excel.programming
|
|||
|
|||
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 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 |
#2
Posted to microsoft.public.excel.programming
|
|||
|
|||
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
Posted to microsoft.public.excel.programming
|
|||
|
|||
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 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 |
#4
Posted to microsoft.public.excel.programming
|
|||
|
|||
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
Posted to microsoft.public.excel.programming
|
|||
|
|||
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 |
Display Modes | |
|
|
Similar Threads | ||||
Thread | Forum | |||
Combinations | Excel Worksheet Functions | |||
combinations | Excel Discussion (Misc queries) | |||
Combinations | Excel Discussion (Misc queries) | |||
Possible Combinations | Excel Discussion (Misc queries) | |||
getting combinations | New Users to Excel |