Sub-String Extraction !

[Eddny]

Hello!

The code below works fine to generate all possible combinations of 37 numbers choosing 6 at a time.
That is, 37 combin 6 = 2,324,784 strings
However, I don't need all the 2M plus output strings. I only need the output strings that contain the numbers "3" and "5".

Of course I could generate all the 2M plus strings and loop over each, test and select the strings containing "3" and "5" but I want the original generation code itself to be modified so that I don't have to re-loop over the output to get the substrings I need.
BTW, the original code was written a while back by someone called Bruno, I believe. (I thought I would give credit to the owner).
Any help would be appreciated.

Ed
========================================

Sub CombinazioniS()


Dim i As Long, j As Long, k As Long, FactClass As Long, n As Long
Dim CS() As Long, NumComb As Long, Elements As Long, Class As Long
Dim TargetRange As Range, S As String, RowsPerColumn As Long, T As
Double


' Definition -------------------------
Elements = 37
Class = 6
Set TargetRange = [Sheet10!CK25]
RowsPerColumn = 500000 ' Printing Layout
' ------------------------------------


T = Timer
' NumComb = Numero delle combinazioni
' ------------------------------------
NumComb = 1
For i = Elements To Elements - Class + 1 Step -1
NumComb = NumComb * i
Next
FactClass = 1
For i = Class To 2 Step -1
FactClass = FactClass * i
Next
NumComb = NumComb / FactClass
' -------------------------------------
ReDim CS(1 To NumComb, 1 To Class)
For i = 1 To Class
CS(1, i) = i
Next
For i = 2 To NumComb
k = Class
Do Until CS(i - 1, k) < Elements - Class + k
k = k - 1
Loop
For j = 1 To k - 1
CS(i, j) = CS(i - 1, j)
Next
CS(i, k) = CS(i - 1, k) + 1
For j = k + 1 To Class
CS(i, j) = CS(i, j - 1) + 1
Next
Next


' Stampa in TargetRange-down
Application.Calculation = xlCalculationManual
Application.ScreenUpdating = False
n = 0: k = 1
For i = 1 To UBound(CS, 1)
S = ""
For j = 1 To UBound(CS, 2)
S = S & CS(i, j) & " "
Next
'MsgBox S
n = n + 1
TargetRange(n, k) = S
If i Mod RowsPerColumn = 0 Then
k = k + 1
n = 0
End If
Next




End Sub

 

[Eddny]

this is the modified code.
In the beginning the calculation of numcomb is done with the combin function.
The cels in the worksheet only contains combinations that have a 3 and a 5.

Sub CombinazioniS()

Dim i As Long, j As Long, k As Long, FactClass As Long, n As Long
Dim CS() As Long, NumComb As Long, Elements As Long, Class As Long
Dim TargetRange As Range, S As String, RowsPerColumn As Long, T As Double


' Definition -------------------------
Elements = 37
Class = 6
Set TargetRange = [Blad1!C3]
RowsPerColumn = 50000 ' Printing Layout
' ------------------------------------


T = Timer
' NumComb = Numero delle combinazioni
' ------------------------------------
NumComb = WorksheetFunction.Combin(Elements, Class)

' -------------------------------------
ReDim CS(1 To NumComb, 1 To Class)
For i = 1 To Class
CS(1, i) = i
Next
For i = 2 To NumComb
k = Class
Do Until CS(i - 1, k) < Elements - Class + k
k = k - 1
Loop
For j = 1 To k - 1
CS(i, j) = CS(i - 1, j)
Next
CS(i, k) = CS(i - 1, k) + 1
For j = k + 1 To Class
CS(i, j) = CS(i, j - 1) + 1
Next
Next


' Stampa in TargetRange-down
Application.Calculation = xlCalculationManual
Application.ScreenUpdating = False
n = 0: k = 1
Dim c3 As Boolean, c5 As Boolean
For i = 1 To UBound(CS, 1)
  S = "": c3 = False: c5 = False
  For j = 1 To UBound(CS, 2)
    If CS(i, j) = 3 Then c3 = True
    If CS(i, j) = 5 Then c5 = True
    S = S & CS(i, j) & " "
  Next j
  'MsgBox S
  If c3 And c5 Then
    n = n + 1
    TargetRange(n, k) = S
  End If
  
  If n Mod RowsPerColumn = 0 Then
    k = k + 1
    n = 0
  End If
Next i

End Sub

ask2tsp -


Thanks, but maybe I need to explain myself better.
Forget about the "3" and "5" inclusion requirement. That has already been addressed by Keebellah's code.


For this second request, what I am looking for is this. Is it possible to create a code that generates the 37 Combin 6 numbers ONE at TIME onto the spreadsheet in TargetRange versus generating all 37 Combin 6 = 2,324,784 numbers into the CS() array first before it outputs to TargetRange?


Due to memory issues with the CS() array, sometimes it gives me insufficient memory errors even before all the lines under ' Stampa in TargetRange-down ' can execute to print all 2,324,784 output strings. So Re-dimensioning CS(1 To NumComb, 1 To Class) may not even execute due to insufficient memory. However, if there was a way to print each item to the sheet, one at a time as it is generated, I will not have the memory issue with the CS() array.

 

[ask2tsp]

Re-dimensioning CS(1 To NumComb, 1 To Class) may not even execute due to insufficient memory

Change Cs() as Long to CS() as Byte saves 1743588 bytes of memory.

 

[ask2tsp]

If you code it like this, you don't need the CS() array anymore:
note: You have to adapt a little bit to your situation:
top-left of output area: init r and c to something other than 1,1 and at 'column turnover' point

Sub generateCombinations()
'print n over k combinations to sheet
    Const N As Integer = 37
    Const K As Integer = 6
    
    Dim combination(1 To K) As Integer
    Dim i       As Integer
    Dim r       As Long
    Dim c       As Long
    Dim node    As Integer
    
    'initialize
    For i = 1 To K: combination(i) = i: Next i
    r = 1: c = 1: node = K
    sh.UsedRange.Clear
    
    toSheet combination, r, c
    
    'next value in node
    While node > 0
        If combination(node) < N Then
            combination(node) = combination(node) + 1
            'track forward
            While node < K
                node = node + 1
                combination(node) = combination(node - 1) + 1
            Wend
            If combination(node) <= N Then toSheet combination, r, c
        Else
            ' last value used, backtrack
            node = node - 1
        End If
    Wend
End Sub

Private Sub toSheet(combination() As Integer, r As Long, c As Long)
    Dim cs As String
    cs = c2s(combination)
    If cs > vbNullString Then
        sh.Cells(r, c).Value = cs
        r = r + 1
        If r Mod 100000 = 0 Then
            c = c + 1: r = 1
            DoEvents
        End If
    End If
End Sub

Private Function c2s(comb() As Integer) As String
    Dim i As Integer, c3 As Boolean, c5 As Boolean
    
    c3 = False: c5 = False
    For i = LBound(comb) To UBound(comb)
        c2s = c2s & " " & comb(i)
        If comb(i) = 3 Then c3 = True
        If comb(i) = 5 Then c5 = True
    Next i
    If Not c3 Or Not c5 Then
        c2s = vbNullString  'only combinations having both 3 and 5
    Else
        c2s = Mid(c2s, 2)   'trim first space
    End If
End Function

 

[mikerickson]

You might want to use this UDF
If you put 1,2,3,4,5,6 in A1:F1

Then select A2:F2 and enter the CSE formula =NextArray(A1:F1, 37, 3, 5) (entered with Ctrl-Shift-Enter (Cmd+Return for Mac))

Then you can drag A2:F2 down as you need, or you can alter A1:F1 and see the next combination.

Note that the "requried elements" (3 and 5) can be altered or elminiated all together.

Function NextArray(ByVal CurrentArray As Variant, MaxEl As Long, ParamArray RequiredElement() As Variant) As Variant
    Dim oneElement As Variant
    Dim ChoiceArray() As Boolean
    Dim Result() As Long
    Dim i As Long, pointer As Long
    Dim isGood As Boolean
    
    ReDim ChoiceArray(1 To MaxEl)
    
    For Each oneElement In CurrentArray
        ChoiceArray(oneElement) = True
        pointer = pointer + 1
        ReDim Result(1 To pointer)
    Next oneElement
    Do
        NextChoice ChoiceArray
        IsGood = True
        For Each oneElement In RequiredElement
            isGood = False
            If ChoiceArray(oneElement) Then
                isGood = True
                Exit For
            End If
        Next oneElement
    Loop Until isGood
    
    pointer = 0
    For i = 1 To MaxEl
        If ChoiceArray(i) Then
            pointer = pointer + 1
            Result(pointer) = i
        End If
    Next i
    NextArray = Result
End Function

Private Function NextChoice(someArray As Variant) As Boolean
    Dim i As Long
    Dim LookAt As Long, WriteTo As Long
    Dim OverFlow As Boolean
    LookAt = 1
    Do Until someArray(LookAt)
        LookAt = LookAt + 1
    Loop
    Do
        WriteTo = WriteTo + 1
        someArray(LookAt) = False
        someArray(WriteTo) = True
        
        LookAt = LookAt + 1
        OverFlow = (UBound(someArray) < LookAt)
        If OverFlow Then Exit Do
    Loop Until Not someArray(LookAt)
    If Not OverFlow Then
        someArray(WriteTo) = False
        someArray(LookAt) = True
    End If
    NextChoice = OverFlow
End Function

 

[Eddny]

If you code it like this, you don't need the CS() array anymore:
note: You have to adapt a little bit to your situation:
top-left of output area: init r and c to something other than 1,1 and at 'column turnover' point

Sub generateCombinations()
'print n over k combinations to sheet
    Const N As Integer = 37
    Const K As Integer = 6
    
    Dim combination(1 To K) As Integer
    Dim i       As Integer
    Dim r       As Long
    Dim c       As Long
    Dim node    As Integer
    
    'initialize
    For i = 1 To K: combination(i) = i: Next i
    r = 1: c = 1: node = K
    sh.UsedRange.Clear
    
    toSheet combination, r, c
    
    'next value in node
    While node > 0
        If combination(node) < N Then
            combination(node) = combination(node) + 1
            'track forward
            While node < K
                node = node + 1
                combination(node) = combination(node - 1) + 1
            Wend
            If combination(node) <= N Then toSheet combination, r, c
        Else
            ' last value used, backtrack
            node = node - 1
        End If
    Wend
End Sub

Private Sub toSheet(combination() As Integer, r As Long, c As Long)
    Dim cs As String
    cs = c2s(combination)
    If cs > vbNullString Then
        sh.Cells(r, c).Value = cs
        r = r + 1
        If r Mod 100000 = 0 Then
            c = c + 1: r = 1
            DoEvents
        End If
    End If
End Sub

Private Function c2s(comb() As Integer) As String
    Dim i As Integer, c3 As Boolean, c5 As Boolean
    
    c3 = False: c5 = False
    For i = LBound(comb) To UBound(comb)
        c2s = c2s & " " & comb(i)
        If comb(i) = 3 Then c3 = True
        If comb(i) = 5 Then c5 = True
    Next i
    If Not c3 Or Not c5 Then
        c2s = vbNullString  'only combinations having both 3 and 5
    Else
        c2s = Mid(c2s, 2)   'trim first space
    End If
End Function

ask2tsp -
Thanks, I like this idea, but when I try to run your code it gives me a compile error of variable not defined and
highlights "sh.UsedRange.Clear" in yellow. It appears your variable "sh" is not defined or set.

 

[Eddny]

You might want to use this UDF
If you put 1,2,3,4,5,6 in A1:F1

Then select A2:F2 and enter the CSE formula =NextArray(A1:F1, 37, 3, 5) (entered with Ctrl-Shift-Enter (Cmd+Return for Mac))

Then you can drag A2:F2 down as you need, or you can alter A1:F1 and see the next combination.

Note that the "requried elements" (3 and 5) can be altered or elminiated all together.

Function NextArray(ByVal CurrentArray As Variant, MaxEl As Long, ParamArray RequiredElement() As Variant) As Variant
    Dim oneElement As Variant
    Dim ChoiceArray() As Boolean
    Dim Result() As Long
    Dim i As Long, pointer As Long
    Dim isGood As Boolean
    
    ReDim ChoiceArray(1 To MaxEl)
    
    For Each oneElement In CurrentArray
        ChoiceArray(oneElement) = True
        pointer = pointer + 1
        ReDim Result(1 To pointer)
    Next oneElement
    Do
        NextChoice ChoiceArray
        IsGood = True
        For Each oneElement In RequiredElement
            isGood = False
            If ChoiceArray(oneElement) Then
                isGood = True
                Exit For
            End If
        Next oneElement
    Loop Until isGood
    
    pointer = 0
    For i = 1 To MaxEl
        If ChoiceArray(i) Then
            pointer = pointer + 1
            Result(pointer) = i
        End If
    Next i
    NextArray = Result
End Function

Private Function NextChoice(someArray As Variant) As Boolean
    Dim i As Long
    Dim LookAt As Long, WriteTo As Long
    Dim OverFlow As Boolean
    LookAt = 1
    Do Until someArray(LookAt)
        LookAt = LookAt + 1
    Loop
    Do
        WriteTo = WriteTo + 1
        someArray(LookAt) = False
        someArray(WriteTo) = True
        
        LookAt = LookAt + 1
        OverFlow = (UBound(someArray) < LookAt)
        If OverFlow Then Exit Do
    Loop Until Not someArray(LookAt)
    If Not OverFlow Then
        someArray(WriteTo) = False
        someArray(LookAt) = True
    End If
    NextChoice = OverFlow
End Function

MikeErickson -
I appreciate your idea as well but after pasting your code in the general area of the module, entering 1,2,3,4,5,6 in A1:F1, I tried to enter the array formula (using CSE) and I got "#NAME?" in each cell in range("A2:F2").
Assuming I wasn't even entering the array formula using CSE correctly, I assigned this code to a command button and run it as: Worksheets("MikErickson").Range("A2:F2").FormulaArray = "=NextArray(A1:F1, 37, 3, 5)"
It still gave me "#NAME?" in each cell in range("A2:F2").

 

[ask2tsp]

Sorry, forgot to say:
In the VBA environment select the sheet where the output has to go, and change the property (name) to sh. Then sh is recognized and there is no need to set it.

 

[Eddny]

Sorry, forgot to say:
In the VBA environment select the sheet where the output has to go, and change the property (name) to sh. Then sh is recognized and there is no need to set it.

ask2tsp - This is looking quite good. In this case, I changed "sh" to Activesheet and it worked.
However, I have 3 questions:


1. Instead of space as delimiters, can it be changed to comma delimiters for the outputs?


2. Can your code be modified where instead of using just 3 and 5 as filtering criteria to determine the output, it can accept any other filtering criteria I choose like say, 1, 2, 5 or 2,4,5,6 (these are just examples) to print out the outputs?


3. What if I want to print ALL the combinations as outputs (without any filtering criteria)? I mean all 36 combination 7 outputs.


I really like your code and think if you can modify it to answer these 3 questions, I will be in good shape.


Thanks, again!


Eddny

 

[mikerickson]

Did you put the code for my UDF in a normal module or the sheet's code module?

 

[ask2tsp]

This is the screen I tested with

Excel Workbook
	A	B	C	D	E
1	Label	Value			1,2,3,4,5,7
2					1,2,3,5,6,7
3	TopLeft Cell	E1			1,2,3,5,7,8
4	Series length	37			1,2,3,5,7,9
5	Selection length	6			1,2,3,5,7,10
6	Filtering criteria	3;5;7			1,2,3,5,7,11
7	Delimiter char	,			1,2,3,5,7,12
8					1,2,3,5,7,13
9					1,2,3,5,7,14
10					1,2,3,5,7,15
11					1,2,3,5,7,16
Sheet

You probably want these lines somewhere else on the sheet. Then you must alter a few llines in the code.
All your requests have been honoured in this version.

Please test this on a copy of your workbook.

Option Explicit

Dim N  As Integer
Dim K  As Integer
Dim delim    As String
Dim filter() As Boolean

Function nbrArgs(spec As String) As Long
    Dim argList() As String
    
    If Len(spec) = 0 Then
        nbrArgs = 0
    Else
        argList = Split(spec, ";")
        nbrArgs = UBound(argList) - LBound(argList) + 1
    End If
End Function

Sub generateCombinations()
'print n over k combinations to sheet
    Dim dataOut As Range
    Dim combination() As Integer
    Dim i       As Integer
    Dim r       As Long
    Dim c       As Long
    Dim node    As Integer
    Dim argList()   As String
    Dim filterSpec  As String
    
    '----- initialize -----
    With ActiveSheet
        N = .Range("B4")
        K = .Range("B5")
        
        ReDim combination(1 To K)
        For i = 1 To K: combination(i) = i: Next i
        
        filterSpec = .Range("B6")
        ReDim filter(1 To N)
        For i = 1 To N: filter(i) = False: Next i
    
        If Len(filterSpec) = 0 Then
            'no filter spec. All numbers are valid
            For i = 1 To N: filter(i) = True: Next i
        Else
            argList = Split(filterSpec, ";")
            For i = 0 To UBound(argList)
                filter(argList(i)) = True
            Next i
        End If
        
        r = 0: c = 0: node = K
        Set dataOut = [indirect(B3)]
        dataOut.Resize(500000, 20).Clear
        
        delim = .Range("B7")
    End With
    '--------------------
    
    toSheet combination, dataOut, r, c
    
    'next value in node
    While node > 0
        If combination(node) < N Then
            combination(node) = combination(node) + 1
            'track forward
            While node < K
                node = node + 1
                combination(node) = combination(node - 1) + 1
            Wend
            If combination(node) <= N Then toSheet combination, dataOut, r, c
        Else
            ' last value used, backtrack
            node = node - 1
        End If
    Wend
End Sub

Private Sub toSheet(combination() As Integer, dto As Range, r As Long, c As Long)
    Dim cs As String
    cs = c2s(combination)
    If cs > vbNullString Then
        dto.Offset(r, c).Value = cs
        r = r + 1
        
        If r Mod 500 Then
            ActiveWindow.ScrollRow = ActiveCell.Row - 5
            DoEvents
        End If
        
        If r Mod 100000 = 0 Then
            c = c + 1: r = 0
        End If
    End If
End Sub

Private Function c2s(comb() As Integer) As String
    Dim i As Integer, present() As Boolean, Selected As Boolean
    
    ReDim present(1 To N)
    For i = LBound(comb) To UBound(comb)
        c2s = c2s & delim & comb(i)
        present(comb(i)) = True
    Next i
    
    Selected = True
    For i = 1 To N
        If filter(i) And Not present(i) Then
            Selected = False
            Exit For
        End If
    Next i
    If Selected Then
        c2s = Mid(c2s, 2)   'trim first delimiter char
    Else
        c2s = vbNullString  'only combinations having filter numbers
    End If
End Function