0

我试图展示相关项目活动的路径。基本上你可以把它想象成一个有向图。我做了一个邻接矩阵。

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

然后我编写了一个子程序来查找所选活动的前身，但我真正需要的是从一开始就显示所有相关活动。例如，如果选择 A1.2，它应该打印出 [STA, A1.1, A1.2]。如果选择了所有活动都超前的最终结果，则应以正确的顺序打印所有活动。不同的路径可以像这样分开 [STA, A1.1, A1.2, ... END],[STA, A2.1, A2.2, ... END],[STA, A3.1, . ..] 到目前为止，我的代码只打印出所选活动的前身：

'---------------------------------
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
'---------------------------------

我的问题是是否可以将子例程 Findpath 更改为递归函数以打印出所有相关活动？

这是完整的邻接矩阵：

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 结束 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 结束 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0

4

1 回答 1

1

是否可以将子例程 Findpath 更改为递归函数的简短回答是 Yes。

但我认为你在想这个。如果我正确理解您的要求，您可以使用Do Loop像这样

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

这STA, A1.1, A1.2从您的示例数据返回

如果数据中存在无限链，您可能需要添加检查以断开

于 2012-12-07T09:20:49.747 回答