Iterate matrix and save results

[Tkeller]

I have a 3 by 3 matrix (where each of the 9 cells is ranked from 1 to 9). The ranking tells the excel model the order that each item is used. Think of it as having 9 books that can be arranged in any order (all together there would be 9! possible was to do this). If its easier, I could arrange this in a 1 column or a row matrix with 9 elements. What I would like to do is to permutate all combinations of rankings, run it through my model, and capture the results. I am mainly interested in capturing the result that gives the highest value (so if there is a way to capture this result (it would mean holding the current highest "result" until a subsequent run replaces it, it would make life easier. I have generalized what I am trying to do, but hopefully it is enough to provide some guidance on how to code it

Thanks,
Tom

 

[shg]

Sub TK()
  Const n           As Long = 9 ' number of items to permute
  Dim aiP(1 To n)   As Long     ' permutation array (0 to n-1, not 1 to n)
  Dim dRes          As Double   ' result of your evaluation function
  Dim dResMax       As Double   ' best result so far
  Dim aiPSav()      As Long     ' cached permutation corresponding to dResMax

  dResMax = -1.7E+308

  aiP(1) = -1  ' to initialize

  Do While bNextPermut(aiP)
    dRes = TKEvaluate(aiP)  ' your evaluate function
    If dRes > dResMax Then
      dResMax = dRes
      aiPSav = aiP
    End If
  Loop

  Stop  ' aiPSav contains the best permutation
End Sub

Function TKEvaluate(aiP() As Long) As Double
  ' whatever
End Function

Function bNextPermut(aiP() As Long) As Boolean
  ' shg 2009-12

  ' VBA only

  ' Returns the next permutation in lexical order in aiP
  ' If aiP(1) < 0, returns the first permutation and True
  ' If aiP is the last permutation, returns aiP(1)= -1 and False

  ' Adapted from Applied Combinatorics/Tucker p. 224

  ' The first (0th) permutation is {  0,   1, ..., n-2, n-1}
  ' The last (n!-1) permutation is {n-1, n-2, ...,   1,   0}

  Dim aiTmp()       As Long
  Dim n             As Long
  Dim i             As Long
  Dim h             As Long
  Dim bWrap         As Boolean

  n = UBound(aiP)

  If aiP(1) < 0 Then
    ' initialize to first permutation
    For i = 1 To n
      aiP(i) = i - 1
    Next i
    bNextPermut = True

  Else
    aiTmp = aiP

    For i = n - 1 To 1 Step -1
      If aiP(i) < aiP(i + 1) Then Exit For
    Next i

    If i Then
      bNextPermut = True

      For h = n To i + 1 Step -1
        If aiP(i) < aiP(h) Then Exit For
      Next h

      aiP(i) = aiP(h)
      aiP(h) = aiTmp(i)
      aiTmp(h) = aiP(h)

      For h = i + 1 To n
        aiP(h) = aiTmp(n + i + 1 - h)
      Next h

    Else
      aiP(1) = -1

    End If
  End If
End Function

 

[Tkeller]

Wow. Thank you so much - I will test this out!

 

[shg]

You're welcome.