VBA with 400000+ Combinations. Can it run faster?

[andrew_milonavic]

Hi everyone,

I'm using a VBA that calculates unique combinations from multiple columns. It works great! but in some cases there are 400000+ combinations before sorting and it runs really slow. I'm far from a VBA expert, any way to speed it up?

Option Explicit

Sub NameCombos()
    'https://www.mrexcel.com/forum/excel-questions/1106189-all-combinations-multiple-columns-without-duplicates.html
    
    Dim lLastColumn As Long
    Dim lLastUsedColumn As Long
    Dim aryNames As Variant
    Dim lColumnIndex As Long
    Dim lWriteRow As Long
    Dim bCarry As Boolean
    Dim lWriteColumn As Long
    Dim rngWrite As Range
    Dim lFirstWriteColumn As Long
    Dim lLastWriteColumn As Long
    Dim oFound As Object
    Dim lRefColumn As Long
    Dim lInUseRow As Long
    Dim lCarryColumn As Long
    Dim lPrint As Long
    Dim lLastIteration As Long
    Dim lIterationCount As Long
    Dim sErrorMsg As String
    Dim bShowError As Boolean
    Dim lLastRow As Long
    Dim lLastRowDeDuped As Long
    Dim aryDeDupe As Variant

    Dim sName As String
    Dim bDupeName As Boolean
    
    Dim oSD As Object
    Dim rngCell As Range
    Dim varK As Variant, varI As Variant, varTemp As Variant, lIndex As Long
    Dim lRowIndex As Long
    Dim rngSortRange As Range
    Dim dteStart As Date
    Dim sOutput As String
    Dim lFirstHSortColumn As Long
    Dim lLastHSortColumn As Long
 
    Dim rngReplace As Range

    
    
    
    
    sErrorMsg = "Ensure a Worksheet is active with a header row starting in A1" & _
        "and names under each header entry."
    
    If TypeName(ActiveSheet) <> "Worksheet" Then
        bShowError = True
    End If
    
    If bShowError Then
        MsgBox sErrorMsg, , "Problems Found in Data"
        GoTo End_Sub
    End If
    
    lLastColumn = Range("A1").CurrentRegion.Columns.Count
    lLastUsedColumn = ActiveSheet.UsedRange.Columns.Count
    ReDim aryNames(1 To 2, 1 To lLastColumn)    '1 holds the in-use entry row
                                                
    'How many combinations? (Order does not matter)
    lLastIteration = 1
    For lColumnIndex = 1 To lLastColumn
        aryNames(1, lColumnIndex) = 2
        aryNames(2, lColumnIndex) = Cells(Rows.Count, lColumnIndex).End(xlUp).Row
        lLastIteration = lLastIteration * (aryNames(2, lColumnIndex) - 1)
    Next
    
    lRefColumn = lLastColumn + 1
    lFirstWriteColumn = lLastColumn + 2
    lLastWriteColumn = (2 * lLastColumn) + 1
    
    Select Case MsgBox("Process a " & lLastColumn & " column table with " & _
        lLastIteration & " possible combinations?" & vbLf & vbLf & _
        "WARNING: Columns right of the input range will be erased before continuing.", vbOKCancel + vbCritical + _
        vbDefaultButton2, "Process table?")
    Case vbCancel
        GoTo End_Sub
    End Select
    
    dteStart = Now()
    
    'Clear all columns right of input range
    If lLastUsedColumn > lLastColumn Then
        Range(Cells(1, lLastColumn + 1), Cells(1, lLastUsedColumn)).EntireColumn.ClearContents
    End If
    Cells(1, lLastWriteColumn + 1).Value = "ComboID"
    
    'Add Output Header
    Range(Cells(1, 1), Cells(1, lLastColumn)).Copy Destination:=Cells(1, lFirstWriteColumn)
    
    'Start checking combinations
    lWriteRow = 2
    For lIterationCount = 1 To lLastIteration
        If lIterationCount / 1000 = lIterationCount \ 1000 Then Application.StatusBar = _
            lIterationCount & " / " & lLastIteration
            
        'Reset the Dupe Name flag
        bDupeName = False
        
        'Check Active Combo for Dupe Names
        'Initialize the scripting dictionary
        Set oSD = CreateObject("Scripting.Dictionary")
        oSD.CompareMode = vbTextCompare
        
        'Load names into scripting dictionary
        For lColumnIndex = lLastColumn To 1 Step -1
            sName = Cells(aryNames(1, lColumnIndex), lColumnIndex).Value
            oSD.Item(sName) = oSD.Item(sName) + 1
        Next
        
        'If there are names, and at least one duplicate, set the bDupeName flag
        If oSD.Count > 0 Then
            varK = oSD.keys
            varI = oSD.Items
            For lIndex = 1 To oSD.Count
                If varI(lIndex - 1) > 1 Then
                    bDupeName = True: Exit For
                End If
            Next
        End If
        
        
        If Not bDupeName Then
            'The current row had names and no duplicates
            'Print Active Combo to the lWriteRow row
            For lColumnIndex = lLastColumn To 1 Step -1
                lWriteColumn = lColumnIndex + lLastColumn + 2
                Set rngWrite = Range(Cells(lWriteRow, lFirstWriteColumn), Cells(lWriteRow, lLastWriteColumn))
                Cells(lWriteRow, lRefColumn + lColumnIndex).Value = Cells(aryNames(1, lColumnIndex), lColumnIndex).Value
            Next
            
            'Uncomment next row to see the lIterationCount for the printed row
            Cells(lWriteRow, lLastWriteColumn + 1).Value = lIterationCount
            
            'Point to the next blank row
            lWriteRow = lWriteRow + 1
            
        End If
    
        'Increment Counters
        'Whether the line had duplicates or not, move to the next name in the
        '  rightmost column, if it was ag the last name, go to the first name in that column and
        '  move the name in the column to the left down to the next name (recursive check if THAT
        '  column was already using the last name for remaining columns to the left)
        aryNames(1, lLastColumn) = aryNames(1, lLastColumn) + 1
        If aryNames(1, lLastColumn) > aryNames(2, lLastColumn) Then
            bCarry = True
            lCarryColumn = lLastColumn
            Do While bCarry = True And lCarryColumn > 0
                aryNames(1, lCarryColumn) = 2
                bCarry = False
                lCarryColumn = lCarryColumn - 1
                If lCarryColumn = 0 Then Exit Do
                aryNames(1, lCarryColumn) = aryNames(1, lCarryColumn) + 1
                If aryNames(1, lCarryColumn) > aryNames(2, lCarryColumn) Then bCarry = True
            Loop
        End If
        
        'Check counter values (for debug)
'        Debug.Print lWriteRow,
'        For lPrint = 1 To lLastColumn
'            Debug.Print aryNames(1, lPrint) & ", ";
'        Next
'        Debug.Print
        DoEvents
    Next
    
    Application.StatusBar = "Sorting"
    Application.ScreenUpdating = False
    
    'Copy row names to right so that each copied row can be sorted alphabetically left to right
    '  this will allow the Excel remove duplicate fuction to remove rows that have identical names
    '  in all of their sorted columns.
    lLastRow = Cells(Rows.Count, lFirstWriteColumn).End(xlUp).Row
    Range(Cells(1, lFirstWriteColumn), Cells(lLastRow, lLastWriteColumn)).Copy Destination:=Cells(1, lLastWriteColumn + 2)
    lFirstHSortColumn = lLastWriteColumn + 2
    lLastHSortColumn = Cells(1, Columns.Count).End(xlToLeft).Column
    
    'Sort each row
    Application.ScreenUpdating = False
    lLastRow = Cells(Rows.Count, lFirstWriteColumn).End(xlUp).Row
    For lRowIndex = 2 To lLastRow
        Set rngSortRange = Range(Cells(lRowIndex, lFirstHSortColumn), Cells(lRowIndex, lLastHSortColumn))
        ActiveSheet.Sort.SortFields.Clear
        ActiveSheet.Sort.SortFields.Add Key:=rngSortRange, _
            SortOn:=xlSortOnValues, Order:=xlAscending, DataOption:=xlSortNormal
        With ActiveSheet.Sort
            .SetRange rngSortRange
            .Header = xlNo
            .MatchCase = False
            .Orientation = xlLeftToRight
            .SortMethod = xlPinYin
            .Apply
        End With
    Next
    
    'Check for duplicate rows in HSort Columns
    '  Can only happen if names are duplicated within an input column
    '  Build aryDeDupe  -- Array(1, 2, 3,...n)  -- to exclude iteration # column

    lLastRow = Cells(Rows.Count, lFirstWriteColumn).End(xlUp).Row
    ReDim aryDeDupe(0 To lLastHSortColumn - lFirstHSortColumn)
    lIndex = 0
    For lColumnIndex = lFirstHSortColumn To lLastHSortColumn
        aryDeDupe(lIndex) = CInt(lColumnIndex - lFirstWriteColumn + 1)
        lIndex = lIndex + 1
    Next
    ActiveSheet.Cells(1, lFirstWriteColumn).CurrentRegion.RemoveDuplicates Columns:=(aryDeDupe), Header:=xlYes
    'Above line won't work unless there are parens around the Columns argument ?????
    
    lLastRowDeDuped = Cells(Rows.Count, lFirstWriteColumn).End(xlUp).Row
    
 
    
    sOutput = lLastIteration & vbTab & " possible combinations" & vbLf & _
        lLastRow - 1 & vbTab & " unique name combinations" & vbLf & _
        IIf(lLastRowDeDuped <> lLastRow, lLastRow - lLastRowDeDuped & vbTab & " duplicate rows removed." & vbLf, "") & _
        lLastRowDeDuped - 1 & vbTab & " printed." & vbLf & vbLf & _
        Format(Now() - dteStart, "hh:mm:ss") & " to process."
    
    ActiveSheet.UsedRange.Columns.AutoFit
    MsgBox sOutput, , "Output Report"
    Debug.Print sOutput
        
End_Sub:

    Application.ScreenUpdating = True
    Application.StatusBar = False
    
End Sub

Any help would be great!

Thanks

Andrew

 

[StephenCrump]

I'm using a VBA that calculates unique combinations from multiple columns. It works great! but in some cases there are 400000+ combinations before sorting and it runs really slow. I'm far from a VBA expert, any way to speed it up?

In a word, yes.

The code you've posted does a lot of reading and writing to Excel, which will really slow down the code. To demonstrate:

Sub Demo()

    Dim i As Long, N As Long, Output() As Long
    Dim t As Double
   
    N = 50000
    ReDim Output(1 To N, 1 To 1)
   
    t = Timer
    For i = 1 To N
        Range("A" & i).Value = i
    Next i
    MsgBox Format(Timer - t, "0.0") & " seconds"

    t = Timer
    For i = 1 To N
        Output(i, 1) = i
    Next i
    Range("B1").Resize(N).Value = Output
    MsgBox Format(Timer - t, "0.0") & " seconds"

End Sub

Based on the linked post, and you other post here: Excel combinations from multiple columns with no duplicates

I assume you're trying to do something like this:

Input
A	A	C	D	B
B	B	D	F	J
C	F	G	I	K
D		H	J
E
Output
A	B	C	D	J
A	B	C	D	K
A	B	C	F	J
A	B	C	F	K
A	B	C	I	J
A	B	C	I	K
A	B	C	J	K
A	B	D	F	J
A	B	D	F	K
A	B	D	I	J
A	B	D	I	K
A	B	D	J	K
A	B	G	D	J
A	B	G	D	K
A	B	G	F	J
A	B	G	F	K
A	B	G	I	J
A	B	G	I	K
A	B	G	J	K
A	B	H	D	J
A	B	H	D	K
A	B	H	F	J
A	B	H	F	K
A	B	H	I	J
A	B	H	I	K
A	B	H	J	K
A	F	C	D	B
A	F	C	D	J
A	F	C	D	K
etc

I've generated this output using VBA code:

Sub Test()

    Dim i As Long, j As Long, Cycle() As Long, Total As Long, Count() As Long, N As Long, m As Long, r As Long, c As Long, Tally As Long, temp As Long, MyInput() As Long
    Dim MyOutput() As String, People() As String
    Dim Duplicate() As Boolean
           
    Total = Range("Total").Value
    r = Range("Input").Rows.Count
    c = Range("Input").Columns.Count
    N = Range("People").Rows.Count
    ReDim People(1 To N)
    ReDim MyInput(1 To r, 1 To c)
    ReDim MyOutput(1 To Total, 1 To c)
    ReDim Cycle(1 To c)
    ReDim Count(1 To c)
   
    For j = 1 To c
        Cycle(j) = Range("Cycle")(j).Value
        Count(j) = Range("Count")(j).Value
        On Error Resume Next
        For i = 1 To r
            MyInput(i, j) = Range("Input")(i, j).Value
        Next i
        On Error GoTo 0
    Next j
    For i = 1 To N
        People(i) = Range("People")(i).Value
    Next i
   
    On Error Resume Next
    Range("Myresults").ClearContents
    On Error GoTo 0
   
    For i = 1 To Total
        ReDim Duplicate(1 To N)
        For j = 1 To c
            m = MyInput(1 + Int((i - 1) / Cycle(j)) Mod Count(j), j)
            If Duplicate(m) Then
                Exit For
            Else
                MyOutput(Tally + 1, j) = People(m)
                Duplicate(m) = True
            End If
        Next j
        If j = c + 1 Then Tally = Tally + 1
    Next i

    With Range("C10").Resize(Tally, c)
        .Value = MyOutput
        .Name = "Myresults"
    End With
   
End Sub

... using a few helper cells to make it faster for me to code (these calcs could also be done in VBA) :

Duplicates.xlsm
	A	B	C	D	E	F	G	H	I	J	K	L	M	N
1	People		Roster							Input
2	A		A	A	C	D	B			1	1	3	4	2
3	B		B	B	D	F	J			2	2	4	6	10
4	C		C	F	G	I	K			3	6	7	9	11
5	D		D		H	J				4		8	10
6	E		E							5
7	F									Count
8	G									5	3	4	4	3
9	H		Output						Total	Cycle
10	I		A	B	C	D	J		720	144	48	12	3	1
11	J		A	B	C	D	K
12	K		A	B	C	F	J
13			A	B	C	F	K
14			A	B	C	I	J
15			A	B	C	I	K
16			A	B	C	J	K
17			A	B	D	F	J
18			A	B	D	F	K
19			A	B	D	I	J
20			A	B	D	I	K
21			A	B	D	J	K
22			A	B	G	D	J
23			A	B	G	D	K
24			A	B	G	F	J
25			A	B	G	F	K
26			A	B	G	I	J
27			A	B	G	I	K
28			A	B	G	J	K
29			A	B	H	D	J
30			A	B	H	D	K
31			A	B	H	F	J
32			A	B	H	F	K
33			A	B	H	I	J
34			A	B	H	I	K
35			A	B	H	J	K
36			A	F	C	D	B
37			A	F	C	D	J
Sheet1

Cell Formulas
Range	Formula
J2:N6	J2	=IFERROR(MATCH(C2,People,),"")
J8:N8	J8	=COUNT(J2:J6)
I10:M10	I10	=J10*J8

Named Ranges
Name	Refers To	Cells
Count	=Sheet1!$J$8:$N$8	I10
Cycle	=Sheet1!$J$10:$N$10	I10
Input	=Sheet1!$J$2:$N$6	J8
People	=Sheet1!$A$2:$A$12	J2:N6
Roster	=Sheet1!$C$2:$G$6	J2

If you have access to the latest Excel functions like FILTER and SEQUENCE, we could also use a formula approach to generate the permutations and filter duplicates.

I suggest you update your Account details so we know what version of Excel you're using, as the best solution may vary by version.