PGC, code needs help

[motilulla]

Hello,

I am working with PGC, code since long time but some how I need help, please can the code can be modified to write output result in a single column separated by "," instead of in multiple columns.

Here below is an example with the code attached how the code output result prints in 4 columns D, E, F &G
I want the result output in a single column "D" separated by coma ",". Like as "A, A, A, A"

*	A	B	C	D	E	F	G	H	I
1	P	4
2	Combinations	FALSE
3	Repetition	TRUE
4
5	Set Col B5 Down	A
6		B		A	A	A	A
7		C		A	A	A	B
8				A	A	A	C
9				A	A	B	A
10				A	A	B	B
11				A	A	B	C
12				A	A	C	A
13				A	A	C	B
14				A	A	C	C
15				A	B	A	A
16				A	B	A	B
17				A	B	A	C
18				A	B	B	A
19				A	B	B	B
20				A	B	B	C
21				A	B	C	A
22				A	B	C	B
23				A	B	C	C
24				A	C	A	A
25				A	C	A	B
26				A	C	A	C
27				A	C	B	A
28				A	C	B	B
29				A	C	B	C
30				A	C	C	A
31				A	C	C	B
32				A	C	C	C
33				B	A	A	A
34				B	A	A	B
35				B	A	A	C
36				B	A	B	A
37				B	A	B	B
38				B	A	B	C
39				B	A	C	A
40				B	A	C	B
41				B	A	C	C
42				B	B	A	A
43				B	B	A	B
44				B	B	A	C
45				B	B	B	A
46				B	B	B	B
47				B	B	B	C
48				B	B	C	A
49				B	B	C	B
50				B	B	C	C
51				B	C	A	A
52				B	C	A	B
53				B	C	A	C
54				B	C	B	A
55				B	C	B	B
56				B	C	B	C
57				B	C	C	A
58				B	C	C	B
59				B	C	C	C
60				C	A	A	A
61				C	A	A	B
62				C	A	A	C
63				C	A	B	A
64				C	A	B	B
65				C	A	B	C
66				C	A	C	A
67				C	A	C	B
68				C	A	C	C
69				C	B	A	A
70				C	B	A	B
71				C	B	A	C
72				C	B	B	A
73				C	B	B	B
74				C	B	B	C
75				C	B	C	A
76				C	B	C	B
77				C	B	C	C
78				C	C	A	A
79				C	C	A	B
80				C	C	A	C
81				C	C	B	A
82				C	C	B	B
83				C	C	B	C
84				C	C	C	A
85				C	C	C	B
86				C	C	C	C
87
88
89

'https://www.mrexcel.com/board/threads/combination-help.277924/page-5#post-1424848
'Combination Help
Option Explicit

'bComb=True, bRepet=False - Combinations without repetition
'bComb=True, bRepet=True - Combinations with repetition
'bComb=False, bRepet=False - Permutations without repetition
'bComb=False, bRepet=True - Permutations without repetition
'-------------------------------------------------------------------------------------------------
'http://www.mrexcel.com/forum/excel-questions/277924-combination-help.html

' PGC Set 2007
' Calculates and writes the Combinations / Permutations with/without repetition
' Assumes the result is written from row 1 down. If the total number of cells in a column
' is less than tha number of results continues in another group of columns to the right.
' vElements - Array with the set elements (1 to n)
' p - number of elements in 1 combination/permutation
' bComb - True: Combinations, False: Permutations
' bRepet - True: with repetition, False: without repetition
' vResult - Array to hold 1 permutation/combination (1 to p)
' lRow - row number. the next combination/permutation is written in lRow+1
' vResultAll - Array to hold all the permutations/combinations (1 to Total, 1 to p)
' iElement - order of the element to process in case of combination
' iIndex - position of the next element in the combination/permutation

' Sub CombPerm() deals with the input / output
' Sub CombPermNP() generates the combinations / permutations

Sub CombPerm()
Dim rRng As Range, p As Integer
Dim vElements As Variant, vResult As Variant, vResultAll As Variant, lTotal As Long
Dim lRow As Long, bComb As Boolean, bRepet As Boolean
Dim vResultPart, iGroup As Integer, l As Long, lMax As Long, k As Long, MaxRow As Long

' Get the inputs and clear the result range (you may adjust for other locations)
Set rRng = Range("B5", Range("B5").End(xlDown)) ' The set of numbers
p = Range("B1").Value ' How many are picked
bComb = Range("B2")
bRepet = Range("B3")
'Range("D1", Cells(1, Columns.Count)).EntireColumn.Clear
Range("D6:IV65536").ClearContents

MaxRow = 65000 'Set Last Row Number For Combination/Permutation To Be Written

' Error
If (Not bRepet) And (rRng.Count < p) Then
    MsgBox "With no repetition the number of elements of the set must be bigger or equal to p"
    Exit Sub
End If

' Set up the arrays for the set elements and the result
vElements = Application.Index(Application.Transpose(rRng), 1, 0)
With Application.WorksheetFunction
    If bComb = True Then
            lTotal = .Combin(rRng.Count + IIf(bRepet, p - 1, 0), p)
    Else
        If bRepet = False Then lTotal = .Permut(rRng.Count, p) Else lTotal = rRng.Count ^ p
    End If
End With
ReDim vResult(1 To p)
ReDim vResultAll(1 To lTotal, 1 To p)

' Calculate the Combinations / Permutations
Call CombPermNP(vElements, p, bComb, bRepet, vResult, lRow, vResultAll, 1, 1)

' Write the  Combinations / Permutations
' Since writing to the worksheet cell be cell is very slow, uses temporary arrays to write one column at a time
Application.ScreenUpdating = False
If lTotal <= MaxRow Then
    Range("D6").Resize(lTotal, p).Value = vResultAll 'you may adjust for other location
Else
    While iGroup * MaxRow < lTotal
        lMax = lTotal - iGroup * MaxRow
        If lMax > MaxRow Then lMax = MaxRow
        ReDim vResultPart(1 To lMax, 1 To p)
        For l = 1 To lMax
            For k = 1 To p
                vResultPart(l, k) = vResultAll(l + iGroup * MaxRow, k)
            Next k
        Next
        Range("D6").Offset(0, iGroup * (p + 1)).Resize(lMax, p).Value = vResultPart
        iGroup = iGroup + 1
    Wend
End If
Application.ScreenUpdating = True
End Sub

Sub CombPermNP(ByVal vElements As Variant, ByVal p As Integer, ByVal bComb As Boolean, ByVal bRepet As Boolean, _
                             ByVal vResult As Variant, ByRef lRow As Long, ByRef vResultAll As Variant, ByVal iElement As Integer, ByVal iIndex As Integer)
Dim i As Integer, j As Integer, bSkip As Boolean

For i = IIf(bComb, iElement, 1) To UBound(vElements)
    bSkip = False
    ' in case of permutation without repetition makes sure the element is not yet used
    If (Not bComb) And Not bRepet Then
        For j = 1 To p
            If vElements(i) = vResult(j) And Not IsEmpty(vResult(j)) Then
                bSkip = True
                Exit For
            End If
        Next
    End If

    If Not bSkip Then
        vResult(iIndex) = vElements(i)
        If iIndex = p Then
            lRow = lRow + 1
            For j = 1 To p
                vResultAll(lRow, j) = vResult(j)
            Next j
        Else
            Call CombPermNP(vElements, p, bComb, bRepet, vResult, lRow, vResultAll, i + IIf(bComb And bRepet, 0, 1), iIndex + 1)
        End If
    End If
Next i
End Sub

Thank you all.

I am using Excel 2000

Regards,
Moti

 

[lrobbo314]

Awesome! Glad it worked for you. Thanks for the feedback.