1
\$\begingroup\$

I have rewritten a recursive procedure to list combinations of values in Excel columns in a way, that instead of one cell string output, there is an array output to Excel range (one value per cell, one combination per row). It lists up to 1 000 000 combinations and executes in 45 seconds / 1 000 000 combinations on my PC. Are any improvements which would let me decrease execution time possible?

   Sub ListCombinations()

    Dim arr As Variant, outCnt As Long, vOut() As Variant
    Dim lastRow As Long
    Dim tim As Double: tim = Timer

    arr = ThisWorkbook.Worksheets("assignment optimization").Range("b2:j12")
    ReDim vOut(1000000, UBound(arr, 2))
    outCnt = 1
    Arrangements arr, vbNullString, LBound(arr, 2), outCnt, vOut

    Application.ScreenUpdating = False

    With ThisWorkbook.Worksheets("assignment optimization")
        With Range(.Cells(1, 12), .Cells(outCnt, 11 + UBound(vOut, 2)))
            lastRow = .Columns.Find(what:="*", searchorder:=xlByRows, searchdirection:=xlPrevious).Row
            .Columns.ClearContents
            .Value = vOut
        End With
    End With

    Application.ScreenUpdating = True

    Debug.Print Timer - tim

End Sub

Sub Arrangements(ByRef arr, ByVal s As String, ByVal lInd As Long, ByRef outCnt As Long, ByRef vOut As Variant)

Dim i As Long, arrayIndex1 As Long

    For i = LBound(arr) To UBound(arr)
        If arr(i, lInd) <> False Then 'exclude values "FALSE" from listing
            If lInd = UBound(arr, 2) Then
                For arrayIndex1 = LBound(vOut, 2) To UBound(vOut, 2)
                    vOut(outCnt, arrayIndex1) = Split(Mid$(s, 2) & "," & arr(i, lInd), ",")(arrayIndex1 - 1)
                Next arrayIndex1
                If outCnt = 1000000 Then Exit Sub
                outCnt = outCnt + 1
            Else
                vOut(outCnt, lInd) = arr(i, lInd)
                Arrangements arr, s & "," & arr(i, lInd), lInd + 1, outCnt, vOut
            End If
        End If
    Next i

End Sub

Edit:

I already found first improvement. Instead of splitting the same string on each arrayIndex1 iteration, I do the splitting outside of the loop and assign it to array. Execution time is now 18 seconds.

Dim outVals () as string

...

outVals = Split(Mid$(s, 2) & "," & arr(i, lInd), ",")

For arrayIndex1 = LBound(vOut, 2) To UBound(vOut, 2)
    vOut(outCnt, arrayIndex1) = outVals(arrayIndex1 - 1)
Next arrayIndex1

Edit 2:

Combinations input and output layout:

Combinations input and output layout:

\$\endgroup\$
3
  • \$\begingroup\$ lastRow is not used, I would Redim Preserve vOut to fit the data. I don't see the point in partially clearing the old list. Please provide some sample data and a screenshot of the desired output (only 10 rows or so). \$\endgroup\$
    – user109261
    Commented Oct 29, 2017 at 15:13
  • \$\begingroup\$ Good catch with lastRow, initially combination columns had header and I was detecting last row, then cleared data from row 2 to last row. I'm not a big fan of Redim Preserve, it requires transposing array and transposing it back, I have a custom procedure to overcome 65k rows limit, but I still find pasting too big array to range which fits desired amount of rows more straightforward. I've added screenshot of input and output data. \$\endgroup\$ Commented Oct 29, 2017 at 20:24
  • \$\begingroup\$ Aww..your are correct. Using Value2 will give you a small boost in speed using your dataset and a most significant boost working with dates. \$\endgroup\$
    – user109261
    Commented Oct 30, 2017 at 5:31

1 Answer 1

1
\$\begingroup\$

I continually get Subscript Out of Range at

vOut(outCnt, arrayIndex1) = Split(Mid$(s, 2) & "," & arr(i, lInd), ",")(arrayIndex1 - 1)

ByRef

Sub Arrangements(ByRef arr, ByVal s As String, ByVal lInd As Long, ByRef outCnt As Long, ByRef vOut As Variant)

Arrangements arr, s & "," & arr(i, lInd), lInd + 1, outCnt, vOut

Why are you passing all these arguments ByRef? Especially because you're calling the procedure from within the procedure. By definition the arr passed ByVal will always persist as will the outCnt. The vOut is being passed back as well, so it doesn't need to be ByRef.

Do you see what I mean? If you had this -

Sub main()
    Dim i As Long
    i = 1
    adding i
End Sub
Sub adding(ByVal i As Long)
    If i > 0 Then i = i + 1
    adding i
End Sub

The i would increase every time it's passed back. What ByRef would be used for is making changes to something that isn't passed back.

That being said, why are you calling your procedure from within your procedure anyway?

Sub Arrangements(ByRef arr, ByVal s As String, ByVal lInd As Long, ByRef outCnt As Long, ByRef vOut As Variant)
For
  If
    If lInd = UBound(arr, 2) Then
   Else
       vOut(outCnt, lInd) = arr(i, lInd)
       Arrangements arr, s & "," & arr(i, lInd), lInd + 1, outCnt, vOut
End If

Seems to me if your second If isn't true, maybe you need to go to the next For? Or does it need to re-perform the entire process again?

Maybe I'm having trouble understanding it. I have no idea what lInd is.

Variables

Give your variables meaningful names. This makes following the code easier and it also makes future you happy that you can take a look and know what is happening without tracing the entire procedure.

  1. arr - tell me of what. e.g. arrayOfCombinations()
  2. outCnt = it's a count of what and where is it going out?
  3. vOut - once again, what is this?
  4. s -?
  5. arrayIndex1 - why is this #1? Is there a second one? Try to never put numerical digits in a variable's name
  6. lInd - this is created as a ByVal argument and then sent back to itself as its own value. I - what?!

I'm not being mean, but how would I ever be able to figure out what lInd is if it's never truly defined and has a name that doesn't tell me much. That's very poor logic (of the procedure, not you).

Magic numbers

I see the number 1,000,000 twice. What is it? The number of combinations?

Const TOTAL_COMBINATIONS as Long = 1000000

Or name it whatever it is.

\$\endgroup\$

Your Answer

By clicking “Post Your Answer”, you agree to our terms of service and acknowledge you have read our privacy policy.

Not the answer you're looking for? Browse other questions tagged or ask your own question.