Help with where the results of a macro get printed

R

Reboshua

Board Regular
Joined
Jan 23, 2015
Messages
88
I am using this old/revised/excellent code to generate combinations. I'm sure the veterans of the forum will know this well.

My question - this vba code takes all of the combinations and prints them on a separate worksheet as a comma separated

Instead, I'd like to print the combinations in cells, one item to a cell, on the same sheet - but I don't know how to modify the code to give these instructions.

​Excel 2016 (Windows) 64 bit[TABLE="class: head"]
<tbody>[TR="bgcolor: [URL=https://www.mrexcel.com/forum/usertag.php?do=list&action=hash&hash=FFFFFF]#FFFFFF[/URL] "]
[TD]C[/TD]
[TD][/TD]
[TD]
1​
[/TD]
[TD]
2​
[/TD]
[TD]
3​
[/TD]
[TD]
4​
[/TD]
[/TR]
[TR="bgcolor: [URL=https://www.mrexcel.com/forum/usertag.php?do=list&action=hash&hash=FFFFFF]#FFFFFF[/URL] "]
[TD]
4​
[/TD]
[TD][/TD]
[TD]Tom Brokaw[/TD]
[TD]Peter Jennings[/TD]
[TD]Dan Rather[/TD]
[TD]Walter Crokite[/TD]
[/TR]
[TR="bgcolor: [URL=https://www.mrexcel.com/forum/usertag.php?do=list&action=hash&hash=FFFFFF]#FFFFFF[/URL] "]
[TD]Tom Brokaw[/TD]
[TD][/TD]
[TD]Tom Brokaw[/TD]
[TD]Peter Jennings[/TD]
[TD]Dan Rather[/TD]
[TD]Edward R. Murrow[/TD]
[/TR]
[TR="bgcolor: [URL=https://www.mrexcel.com/forum/usertag.php?do=list&action=hash&hash=FFFFFF]#FFFFFF[/URL] "]
[TD]Peter Jennings[/TD]
[TD][/TD]
[TD]Tom Brokaw[/TD]
[TD]Peter Jennings[/TD]
[TD]Dan Rather[/TD]
[TD]Rachel Maddow[/TD]
[/TR]
[TR="bgcolor: [URL=https://www.mrexcel.com/forum/usertag.php?do=list&action=hash&hash=FFFFFF]#FFFFFF[/URL] "]
[TD]Dan Rather[/TD]
[TD][/TD]
[TD]Tom Brokaw[/TD]
[TD]Peter Jennings[/TD]
[TD]Walter Crokite[/TD]
[TD]Edward R. Murrow[/TD]
[/TR]
[TR="bgcolor: [URL=https://www.mrexcel.com/forum/usertag.php?do=list&action=hash&hash=FFFFFF]#FFFFFF[/URL] "]
[TD]Walter Crokite[/TD]
[TD][/TD]
[TD]Tom Brokaw[/TD]
[TD]Peter Jennings[/TD]
[TD]Walter Crokite[/TD]
[TD]Rachel Maddow[/TD]
[/TR]
[TR="bgcolor: [URL=https://www.mrexcel.com/forum/usertag.php?do=list&action=hash&hash=FFFFFF]#FFFFFF[/URL] "]
[TD]Edward R. Murrow[/TD]
[TD][/TD]
[TD]Tom Brokaw[/TD]
[TD]Peter Jennings[/TD]
[TD]Edward R. Murrow[/TD]
[TD]Rachel Maddow[/TD]
[/TR]
[TR="bgcolor: [URL=https://www.mrexcel.com/forum/usertag.php?do=list&action=hash&hash=FFFFFF]#FFFFFF[/URL] "]
[TD]Rachel Maddow[/TD]
[TD][/TD]
[TD]Tom Brokaw[/TD]
[TD]Dan Rather[/TD]
[TD]Walter Crokite[/TD]
[TD]Edward R. Murrow[/TD]
[/TR]
[TR="bgcolor: [URL=https://www.mrexcel.com/forum/usertag.php?do=list&action=hash&hash=FFFFFF]#FFFFFF[/URL] "]
[TD][/TD]
[TD][/TD]
[TD]Tom Brokaw[/TD]
[TD]Dan Rather[/TD]
[TD]Walter Crokite[/TD]
[TD]Rachel Maddow[/TD]
[/TR]
[TR="bgcolor: [URL=https://www.mrexcel.com/forum/usertag.php?do=list&action=hash&hash=FFFFFF]#FFFFFF[/URL] "]
[TD][/TD]
[TD][/TD]
[TD]Tom Brokaw[/TD]
[TD]Dan Rather[/TD]
[TD]Edward R. Murrow[/TD]
[TD]Rachel Maddow[/TD]
[/TR]
[TR="bgcolor: [URL=https://www.mrexcel.com/forum/usertag.php?do=list&action=hash&hash=FFFFFF]#FFFFFF[/URL] "]
[TD][/TD]
[TD][/TD]
[TD]Tom Brokaw[/TD]
[TD]Walter Crokite[/TD]
[TD]Edward R. Murrow[/TD]
[TD]Rachel Maddow[/TD]
[/TR]
[TR="bgcolor: [URL=https://www.mrexcel.com/forum/usertag.php?do=list&action=hash&hash=FFFFFF]#FFFFFF[/URL] "]
[TD][/TD]
[TD][/TD]
[TD]Peter Jennings[/TD]
[TD]Dan Rather[/TD]
[TD]Walter Crokite[/TD]
[TD]Edward R. Murrow[/TD]
[/TR]
[TR="bgcolor: [URL=https://www.mrexcel.com/forum/usertag.php?do=list&action=hash&hash=FFFFFF]#FFFFFF[/URL] "]
[TD][/TD]
[TD][/TD]
[TD]Peter Jennings[/TD]
[TD]Dan Rather[/TD]
[TD]Walter Crokite[/TD]
[TD]Rachel Maddow[/TD]
[/TR]
[TR="bgcolor: [URL=https://www.mrexcel.com/forum/usertag.php?do=list&action=hash&hash=FFFFFF]#FFFFFF[/URL] "]
[TD][/TD]
[TD][/TD]
[TD]Peter Jennings[/TD]
[TD]Dan Rather[/TD]
[TD]Edward R. Murrow[/TD]
[TD]Rachel Maddow[/TD]
[/TR]
[TR="bgcolor: [URL=https://www.mrexcel.com/forum/usertag.php?do=list&action=hash&hash=FFFFFF]#FFFFFF[/URL] "]
[TD][/TD]
[TD][/TD]
[TD]Peter Jennings[/TD]
[TD]Walter Crokite[/TD]
[TD]Edward R. Murrow[/TD]
[TD]Rachel Maddow[/TD]
[/TR]
[TR="bgcolor: [URL=https://www.mrexcel.com/forum/usertag.php?do=list&action=hash&hash=FFFFFF]#FFFFFF[/URL] "]
[TD][/TD]
[TD][/TD]
[TD]Dan Rather[/TD]
[TD]Walter Crokite[/TD]
[TD]Edward R. Murrow[/TD]
[TD]Rachel Maddow[/TD]
[/TR]
</tbody>[/TABLE]
[TABLE="class: grid"]
<tbody>[TR]
[TD]Sheet: T1
[/TD]
[/TR]
</tbody>[/TABLE]

Here is the code:



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


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.CountLarge - 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.CountLarge 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
 

Excel Facts

Last used cell?
Press Ctrl+End to move to what Excel thinks is the last used cell.
Sort by date Sort by votes
Try this.
Code: 
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


Sub ListPermutations()
Dim Rng As Range
Dim PopSize As Long
Dim SetSize As Long
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.CountLarge - 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.CountLarge Then GoTo DataError
    Application.ScreenUpdating = False
    Set Results = ActiveSheet
    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 Long = 0, _
                           Optional SetSize As Long = 0, _
                           Optional NextMember As Long = 0)
Static iPopSize As Long
Static iSetSize As Long
Static SetMembers() As Long
Static Used() As Long
Dim I As Long
    If PopSize <> 0 Then
        iPopSize = PopSize
        iSetSize = SetSize
        ReDim SetMembers(1 To iSetSize) As Long
        ReDim Used(1 To iPopSize) As Long
        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 Long = 0, _
                           Optional SetSize As Long = 0, _
                           Optional NextMember As Long = 0, _
                           Optional NextItem As Long = 0)
Static iPopSize As Long
Static iSetSize As Long
Static SetMembers() As Long
Dim I As Long
    If PopSize <> 0 Then
        iPopSize = PopSize
        iSetSize = SetSize
        ReDim SetMembers(1 To iSetSize) As Long
        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 Long, _
                            Optional FlushBuffer As Boolean = False)
Dim I As Long, sValue As String
Static RowNum As Long, ColNum As Long
Dim arrBuffer As Variant

    If RowNum = 0 Then RowNum = 1
    If ColNum = 0 Then ColNum = 3
    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
            For I = 1 To UBound(Buffer)
                If Buffer(I) <> "" Then
                    arrBuffer = Split(Buffer(I), ",")
                    Results.Cells(I, ColNum).Resize(, UBound(arrBuffer) + 1).Value = arrBuffer
                End If
            Next I
            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    'SavePermutationEnd Sub
 
Upvote 0
Norie - this worked perfectly. Thank you so much.

Would you mind teaching me which part of the code controls where the output prints? It's currently staring at C1, but I may want to alter that for other purposes later.
 
Last edited:
Upvote 0
Norie, one other thing I neglected to mention. The macro adds a space in front of the second, third, and fourth items generated in the combination. This creates problems with lookups in other places. How can I get that space removed?

Thank you again,

David
 
Upvote 0
Change this,
Code: 
sValue = sValue & ", " & vAllItems(ItemsChosen(I), 1)
to this.
Code: 
sValue = sValue & "," & vAllItems(ItemsChosen(I), 1)
 
Upvote 0
Norie said:
Change this,
Code: 
sValue = sValue & ", " & vAllItems(ItemsChosen(I), 1)
to this.
Code: 
sValue = sValue & "," & vAllItems(ItemsChosen(I), 1)
Click to expand...


I did try that when combing through the code for a comma and space, but if I do that, it ends up truncating the very first variable's first letter. The first output element in cell c2 above is perfect, no space before it begins. It's the other 3 that have the space.

Thoughts?
 
Upvote 0
Try this.
Rich (BB code): 
    '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, 2)
 
Upvote 0
You must log in or register to reply here.

Similar threads

N
  • Question Question
Myrna Larson-Permutations and Combinations
Replies
0
Views
300
Norman A
N
S
  • Question Question
how to dim nextrow statement to this code??
2
Replies
13
Views
2K
hiker95
H
A
  • Question Question
Myrna Larson code for Combinations and Permutations not working
Replies
0
Views
937
alexransome
A
L
  • Question Question
Improve the Myrna Larson Function - Combinations and Permutations Code for MS Access
Replies
2
Views
884
Micron
M
S
  • Question Question
Adding Break or to Stop macro at certain rows?
2
Replies
13
Views
1K
ZVI
ZVI

Forum statistics

Threads
1,223,954
Messages
6,175,603
Members
452,660
Latest member
Zatman

Share this page

We've detected that you are using an adblocker.

We have a great community of people providing Excel help here, but the hosting costs are enormous. You can help keep this site running by allowing ads on MrExcel.com.
Allow Ads at MrExcel

Which adblocker are you using?

Disable AdBlock

Follow these easy steps to disable AdBlock

1)Click on the icon in the browser’s toolbar.
2)Click on the icon in the browser’s toolbar.
2)Click on the "Pause on this site" option.
Go back

Disable AdBlock Plus

Follow these easy steps to disable AdBlock Plus

1)Click on the icon in the browser’s toolbar.
2)Click on the toggle to disable it for "mrexcel.com".
Go back

Disable uBlock Origin

Follow these easy steps to disable uBlock Origin

1)Click on the icon in the browser’s toolbar.
2)Click on the "Power" button.
3)Click on the "Refresh" button.
Go back

Disable uBlock

Follow these easy steps to disable uBlock

1)Click on the icon in the browser’s toolbar.
2)Click on the "Power" button.
3)Click on the "Refresh" button.
Go back
Back
Top