Looking for more efficient algorithm in vba to evaluate an exponentially growing combinatorics problem

Question

Small introduction:

I have a set of elements that need to be combined to get all permutations. Given a few additional rules for those permutations i already wrote a light-weight recursive procedure to generate all those permutations and so far I am okay with the speed of this process.

The problem:

The "permutations" are given for a set of elements as follows: Each number is only allowed once, other than that all possible combinatations are allowed

Elements: 1a, 1b, 1c, 2a, 2b, 3a, 3b, 3c, 5a, 5b

Bundles of connections:
1a-2a-3a-5a
1a-2a-3a-5b
1a-2a-3b-5a
1a-2a-3b-5b
1a-2a-3c-5a
1a-2a-3c-5b
1a-2b-3a-5a
1a-2b-3a-5b
...

For each permutation I want to calculate a score which is defined by all the neighbouring connections inside a single combination. For example:

score(1a-3c-15g-4e-2a) = connection(1a-3c) 
                       + connection(3c-15g) 
                       + connection(15g-4e)
                       + connection(4e-2a)

All the individual connections are give in form of a table as Worksheet in Excel, with a top and left row holding the single elements. The connecting values are than given in form of a range.

The number of permutations can be approximated by 2*x^(x+1) with x being allowed up to 15.

As you can imagine, the large number of permutations calls for a very efficient algorithm to be able to compute it in a reasonable time. So far I can manage x=8 in 3 minutes and x=9 in under an hour. But x=10 would take an entire day.

My approach so far:

My first instinct was to look at each permutation at once, filter out each connection and use the following code-snippet:

Dim pos1 as Long
Dim pos2 as Long
'k_D : array of all elements (from leftmost column where all connections are stored)
'eg: 1a, 1b, 1c, 2a, 2b, 3a, 3b, 3c, 3d, ... 15f, 15g

pos1 = CLng(Application.WorksheetFunction.Match(current_first, k_D, 0))'position of first element
pos2 = CLng(Application.WorksheetFunction.Match(current_last, k_D, 0))  'position of second element

With this I can simply address the needed connection by cell-reference.
This is the fastest I came up so far!

Other approaches included creating some sort of a lookup array with all connections and all the values to reduce it to just one call of MATCH. This was much slower - I assume 2 calls on an array size n is faster than 1 call to an array with size n^2.

Most other changes I made tackled other parts of the code, which never really changed anything. The MATCH function seems to be the real bottleneck in my approach.

I am hoping a new set of eyes could give some new new ideas.

UPDATE 2020_09_30 - 13:30 As asked: My implementation on how to get the score of each bundle.

Function getConsistency(current_buendel As String)
    'This function takes a bundle like "1a-2a-3a" und sums up all given entries. 

    Dim i1, i2, i3 As Integer
    Dim pos1 As Long
    Dim pos2 As Long
    Dim sum, sum_temp As Integer
    Dim current_connection, current_first, current_last As String
    Dim connections As Integer
    connections = 0

    Dim i As Integer
    Dim elem As Variant
    
    sum = 0
    Dim counter
    counter = 0

    connections = UBound(Split(current_bundle, "-"))
    
    Do
        'At first the current_bundle is cut into two pieces
        'eg 1a-2a-3a-4a -> 1a-2a and 2a-3a-4a

        'find first '-'
        i1 = InStr(1, current_bundle, "-", vbTextCompare)
        'find second '-'
        i2 = InStr(i1 + 1, current_bundle, "-", vbTextCompare)
         
        'split current_bundle in two parts
        If i2 > 0 Then
            current_connection = Left(current_bundle, i2 - 1)
            current_bundle = Right(current_bundle, Len(current_bundle) - i1)
        Else
            current_connection = current_bundle
        End If
        
        'work on current connection
        ' Split in two parts
        'eg 1a-2a -> 1a and 2a
        i3 = InStr(1, current_connection, "-", vbTextCompare)
        current_first = Left(current_connection, i3 - 1)
        current_last = Right(current_connection, Len(current_connection) - i3)
        
        'get vertical positions of those projections
        pos1 = CLng(Application.WorksheetFunction.Match(current_first, k_D, 0))
        pos2 = CLng(Application.WorksheetFunction.Match(current_last, k_D, 0))

        'Handle results
        'This can be done, since the entries in k_ALL2 are lower diagonal
        'shift pos1 and pos2 according to where the matrix is located
        If pos1 < pos2 Then
            sum_temp = k_ALL2(pos2, pos1 + 1)
        Else
            sum_temp = k_ALL2(pos1, pos2 + 1)
        End If
        sum = sum + sum_temp

    Loop While i2 > 0
    
    getConsistency = Array(sum, sum / connections, counter)
End Function

The two ranges/arrays k_D and k_ALL2 are presented here:

user_4996248 · Answer

The biggest speedup would be obtained by touching the spreadsheet as little as possible. Create a global dictionary which associates strings like "2c" to the index in the values, and store those values themselves in a global array. If you are looping over a large number of bundles, the initialization code will only run once:

Option Explicit

'module-level variables:

Dim index As Variant
Dim connections As Variant
Dim initialized As Boolean

Sub Initialize()
    initialized = True
    Dim i As Long, n As Long
    Set index = CreateObject("Scripting.Dictionary")
    index.CompareMode = 1
    With Range("k_D")
        n = .Cells.Count
        For i = 1 To n
            index.Add .Cells(i).Value, i
        Next i
    End With
    
    connections = Range("K_ALL2").Value
End Sub

Function getConsistency(current_bundle As String) As Variant
    'This function takes a bundle like "1a-2a-3a" und sums up all given entries.
    Dim i As Long, r As Long, c As Long
    Dim sum As Variant, terms As Variant
    
    If Not initialized Then Initialize
    
    terms = Split(current_bundle, "-")
    sum = 0
    For i = 0 To UBound(terms) - 1
        r = index(Trim(terms(i)))
        c = index(Trim(terms(i + 1)))
        If r > c Then
            sum = sum + connections(r, c)
        Else
            sum = sum + connections(c, r)
        End If
    Next i
    getConsistency = sum
End Function

Looking for more efficient algorithm in vba to evaluate an exponentially growing combinatorics problem

1 Answers