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]

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

mikerickson -
On the desired/selected worksheet, I did ALT+F11 and pasted your code in the module ("General" dropdown), saved and ran it as I have done for every UDF I have used in the past, and it gave me "#NAME?" in each cell in range("A2:F2") even after populating A1:F1 first.
I am unsure what you mean by "normal module or the sheet's code module," but if I need to do it differently please let me know.

 

[Eddny]

This is the screen I tested with

	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

<colgroup><col style="width:30px; "><col style="width:112.67px;"><col style="width:82px;"><col style="width:22.67px;"><col style="width:103.33px;"><col style="width:103.33px;"></colgroup><tbody>
</tbody>

Excel tables to the web >> Excel Jeanie HTML 4


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

ask2tsp -


I tested your code and it is looking exciting. However:


1. When I leave the Filtering Criteria/Range("B6") blank, I expect it to print ALL the n combination k outputs to sheet and it doesn't do that.


2. If I want the max column turnover to be changed from 100,000 cells deep per column to 1,000,000 cells deep per column, is it just a matter of changing " If r Mod 100000 = 0 Then..." to "If r Mod 1000000 = 0 Then..." ?


3. What is the purpose of this code?
Set dataOut = [indirect(B3)]
dataOut.Resize(500000, 20).Clear


4. Is the purpose of this code just to scroll?
If r Mod 500 Then
ActiveWindow.ScrollRow = ActiveCell.Row - 5
DoEvents
End If


I appreciate the assistance.
Eddny

 

[mikerickson]

mikerickson -
On the desired/selected worksheet, I did ALT+F11 and pasted your code in the module ("General" dropdown), saved and ran it as I have done for every UDF I have used in the past, and it gave me "#NAME?" in each cell in range("A2:F2") even after populating A1:F1 first.
I am unsure what you mean by "normal module or the sheet's code module," but if I need to do it differently please let me know.

Open the VB Editor. From the Insert menu, select Module (not Class Module). That is a normal module. An sheet's code module is gotten to by double clicking on the object in the Project Explorer window.

 

[ask2tsp]

1. When I leave the Filtering Criteria/Range("B6") blank, I expect it to print ALL the n combination k outputs to sheet and it doesn't do that.

Corrected this

2. If I want the max column turnover to be changed from 100,000 cells deep per column to 1,000,000 cells deep per column, is it just a matter of changing " If r Mod 100000 = 0 Then..." to "If r Mod 1000000 = 0 Then..." ?

You assumed right, but I changed it a bit. Now you can change this value at the very beginning of this module

3. What is the purpose of this code?
Set dataOut = [indirect(B3)]
dataOut.Resize(500000, 20).Clear

See comment added

4. Is the purpose of this code just to scroll?
If r Mod 500 Then
ActiveWindow.ScrollRow = ActiveCell.Row - 5
DoEvents
End If

This intended purpose, sctolling so you can monitor it's progress, did not work so I scratched it.

See the results of these minor changes

Option Explicit

Const maxOutRows As Long = 100000   '<== change if you like

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
            argList = Split(filterSpec, ";")
            For i = 0 To UBound(argList)
                filter(argList(i)) = True
            Next i
        End If
        
        r = 0: c = 0: node = K
        'set range of topleft cel of data output area
        'to what is in cel B3
        '[...] is shorthand for evaluate
        Set dataOut = [indirect(B3)]
        'from this topleft location erase an area of the sheet
        dataOut.Resize(maxOutRows, 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 1000 Then
            DoEvents    'allow some action
        End If
        
        If r Mod maxOutRows = 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

 

[Eddny]

Open the VB Editor. From the Insert menu, select Module (not Class Module). That is a normal module. An sheet's code module is gotten to by double clicking on the object in the Project Explorer window.

mikerickson -
Thanks, I was able to add it to the module as you directed and it worked nicely. I appreciate it. I will be generating a lot of combinations for different N and k values, so I will use it when the circumstance fits.

 

[Eddny]

Corrected this

You assumed right, but I changed it a bit. Now you can change this value at the very beginning of this module

See comment added

This intended purpose, sctolling so you can monitor it's progress, did not work so I scratched it.

See the results of these minor changes

Option Explicit

Const maxOutRows As Long = 100000   '<== change if you like

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
            argList = Split(filterSpec, ";")
            For i = 0 To UBound(argList)
                filter(argList(i)) = True
            Next i
        End If
        
        r = 0: c = 0: node = K
        'set range of topleft cel of data output area
        'to what is in cel B3
        '[...] is shorthand for evaluate
        Set dataOut = [indirect(B3)]
        'from this topleft location erase an area of the sheet
        dataOut.Resize(maxOutRows, 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 1000 Then
            DoEvents    'allow some action
        End If
        
        If r Mod maxOutRows = 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

ask2tsp -


Thanks! This is exactly what I was looking for. Your code is very versatile with lots of options. It is a masterpiece, really!


Question: If I want to track how many outputs has been generated so far and show it in the status bar, do I need to initialize a counter and add it like below and where in the code will I place it?

Dim CurrentOutputCount as Long '--- Dimension counter

CurrentOutputCount = 0 '----------- Initialize counter

CurrentOutputCount = CurrentOutputCount + 1 '------ Everytime an output prints to sheet, increment counter by 1

Application.StatusBar = "Outputs Count Generated So Far: "  & CurrentOutputCount '------ Display counter in StatusBar

Thanks, again!
Eddny