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 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 00A2。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 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 10A5。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

4

1 に答える 1

1

簡単な答えは、サブルーチンFindpathを再帰関数に変更することが可能であるということです。

しかし、私はあなたがこれを考えすぎていると思います。私があなたの要件を正しく理解しているなら、あなたは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 に答える