excel vba recursive function

Question

I am trying to show a path of related project activities. Basically you can think of it as a directed graph. I made an adjacency matrix of it.

      STA A1.1 A1.2 ...
STA    0   1    0   ... 
A1.1   0   0    1   ...
A1.2   0   0    0   ...
...   ... ...  ...  ...

Then I wrote a subroutine to find the predecessors of a selected activity but what I would really need is to show all related activities from the start. For the example if A1.2 is selected it should print out [STA, A1.1, A1.2]. If the end result is selected where all activities lead too all activities should be printed out in the correct order. The different paths could be separated like this [STA, A1.1, A1.2, ... END],[STA, A2.1, A2.2, ... END],[STA, A3.1, ...] My code so far which prints out only the predecesoors of a chosen activity:

'---------------------------------
Sub RunThings()

Application.ScreenUpdating = False

 Call UserInput

Application.ScreenUpdating = True

End Sub
'---------------------------------
Sub UserInput()

Dim iReply As Variant

iReply = Application.InputBox(Prompt:="Please enter activity name", Title:="FIND     ACTIVITY PATH", Type:=2)

'MsgBox (iReply)

If iReply = False Then
    Exit Sub
Else 'They cancelled (VbCancel)
    If iReply <> "" Then
        Call Findpath(CStr(iReply))
    End If
End If

Exit Sub

End Sub

'---------------------------------

Function FindRowCol(term As String, row As Boolean)

Dim SearchRange As Range
Dim FindRC As Range

If row = False Then
    Set SearchRange = Range("A1", Range("T1").End(xlUp))
Else
    Set SearchRange = Range("A1", Range("A65536").End(xlUp))
End If

Set FindRC = SearchRange.Find(term, LookIn:=xlValues, lookat:=xlWhole)

If row = False Then
    FindRowCol = FindRC.Column
Else
    FindRowCol = FindRC.row
End If

End Function
'---------------------------------

Sub Findpath(activity As String)

Application.ScreenUpdating = False


ActCol = FindRowCol(activity, False)


For i = 2 To 65536
    If Cells(i, 1).Value = "" Then
        LastRow = Cells(i, 1).row - 1
        Exit For
    End If
Next i

Dim Predecessors() As Variant
Dim Counter As Integer
Counter = 0

For j = 1 To LastRow
    If Cells(j, ActCol).Value = 1 Then
       Counter = Counter + 1

    End If
Next j

ReDim Predecessors(1 To Counter)

Insert = 1

For j = 1 To LastRow
    If Cells(j, ActCol).Value = 1 Then
       Predecessors(Insert) = Cells(j, 1).Value
       Insert = Insert + 1
    End If
Next j

Dim CurrAct As String

For k = LBound(Predecessors) To UBound(Predecessors)

    CurrAct = CStr(Predecessors(k))
    MsgBox (CurrAct)

Next k

Application.ScreenUpdating = True

End Sub
'---------------------------------

My question would be is it possible to change the subroutine Findpath into a recursive function to print out all related activities?

This is the complete adjacency matrix:

STA A1.1 A1.2 A1.3 A1.4 A1.5 A2.1 A2.2 A2.3 A2.4 A2.5 A3.1 A4.1 A4.2 A4.3 A4.4 A4.5 A5.1 END STA 0 1 0 0 0 0 1 0 0 0 0 1 1 0 0 0 0 0 0 A1.1 0 0 1 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 A1.2 0 0 0 1 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 A1.3 0 0 0 0 1 0 0 0 0 0 0 0 0 0 0 0 0 0 0 A1.4 0 0 0 0 0 1 0 0 0 0 0 0 0 0 0 0 0 0 0 A1.5 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 1 0 A2.1 0 0 0 0 0 0 0 1 0 0 0 0 0 0 0 0 0 0 0 A2.2 0 0 0 0 0 0 0 0 1 0 0 0 0 0 1 0 0 0 0 A2.3 0 0 0 0 0 0 0 0 0 1 1 0 0 0 0 0 0 0 0 A2.4 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 1 0 A2.5 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 1 0 A3.1 0 0 0 0 0 0 0 1 0 0 0 0 0 1 0 0 0 0 0 A4.1 0 0 0 0 0 0 0 0 0 0 0 0 0 1 0 0 0 0 0 A4.2 0 0 0 0 0 0 0 0 0 0 0 0 0 0 1 0 0 0 0 A4.3 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 1 1 0 0 A4.4 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 1 0 A4.5 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 1 0 A5.1 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 1 END 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0

chris neilsen · Accepted Answer · 2012-12-07 09:20:49Z

1

Short answer to is it possible to change the subroutine Findpath into a recursive function is Yes.

But I think your are over thinking this. If I understand your requirement correctly, you can do it with a Do Loop, like this

Sub Demo()
    Findpath ActiveSheet, "A1.2"
End Sub

Sub Findpath(sh As Worksheet, activity As String)
    Dim rHeader1 As Range
    Dim rHeader2 As Range
    Dim x, y
    Dim nxtActivity As String
    Dim sPath As String

    With sh
        Set rHeader1 = .Range(.Cells(1, 2), .Cells(1, 2).End(xlToRight))
        Set rHeader2 = .Range(.Cells(2, 1), .Cells(2, 1).End(xlDown))
        nxtActivity = activity
        sPath = activity
        Do
            x = Application.Match(nxtActivity, rHeader1, 0)
            If IsError(x) Then
                Exit Do
            Else
                y = Application.Match(1, rHeader2.Offset(0, CLng(x)), 0)
                If IsError(y) Then
                    Exit Do
                Else
                    nxtActivity = Application.Index(rHeader2, CLng(y))
                    sPath = nxtActivity & ", " & sPath
                End If

            End If
        Loop
    End With

    MsgBox sPath
End Sub

This returns STA, A1.1, A1.2 from your sample data

You might want to add a check to break out if an endless chain is present in the data

answered Dec 7, 2012 at 9:20

chris neilsen

53.3k10 gold badges91 silver badges127 bronze badges

Sign up to request clarification or add additional context in comments.

3 Comments

Stephen Younger Over a year ago

Hi. Thx for comment. I tried your code with the complete matrix (added it below source code) on the activity A5.1 and got STA, A1.1, A1.2, A1.3, A1.5, A5.1 which is correct but only one path. You see all activities lead into A5.1 and there are more predecessors for it. Actually it has five which means I would need five paths to this activity to see all related activities.

Stephen Younger Over a year ago

Sorry - it must be nine paths if all permutations are included.

Stephen Younger Over a year ago

My god I'm dense. Just have to combine my code with yours. Thanks a bunch.

Collectives™ on Stack Overflow

excel vba recursive function

1 Answer 1

3 Comments

Your Answer

Hot Network Questions

Collectives™ on Stack Overflow

1 Answer 1

3 Comments

Your Answer

Sign up or log in

Post as a guest

Related