Hi, I need a little help with Graphs. If anyone can help would be highly appreciated. I have this following scenario, the code I have written to implement it is given as under however, it does not work in some scenario.
The following is a directional graph (Note that the direction is clockwise). I want an output in same sheet as shown in the table.
Thanks
The following is a directional graph (Note that the direction is clockwise). I want an output in same sheet as shown in the table.
Code:
Sub AutoAssign()
Dim IL As Long
Dim JL As Long
Dim KL As Long
Dim Lastrow As Long
Dim AssignLoop As Long
Dim CurrentRow As Long
Dim rFind As Range
Dim FindNode As Long
Dim NodeRecQ() As Long
Dim JLPd() As Long
Dim NPr() As Long
Dim IPr() As Long
Dim NIPr() As Long
Dim closedNode As Long
Rw = 7
IL = 13
'Clearing up the Range
Worksheets("Sheet1").Activate
Range("D" & Rw + 1 & ":E" & Rw + 1 + IL).Clear
' Node
ReDim JLPd(IL, 2)
ReDim NPr(IL, 20)
ReDim NIPr(IL)
For i = 1 To IL
JLPd(i, 1) = Range("C" & Rw + i) ' Nodal Data from - At Design Sheet To Node
JLPd(i, 2) = Range("B" & Rw + i) ' Nodal Data from - At Design Sheet From Node
Next i
'Identify Direction
For j = 1 To IL
IA = 0
For i = 1 To IL
If j = JLPd(i, 1) Then
IA = IA + 1
NPr(j, IA) = JLPd(i, 2) ' Nodal Data
NIPr(j) = IA
End If
Next i
Next j
Dim TempAdd As New Collection
Dim TempAdd2() As Long
Dim getLowest As Long
AssignLoop = 1
For i = 1 To IL
If Range("B" & i + Rw) > Range("C" & i + Rw) Then
Range("D" & i + Rw).value = AssignLoop
'Get the Node no after assigning loop
closedNode = Range("C" & i + Rw).value
Dim ToNodeNoAt As Long
' Reverse loop till closedNode node is found.
Lastrow = Cells(Rows.Count, "D").End(xlUp).Row
ToNodeNoAt = Lastrow
Do While Range("B" & Lastrow) <> Range("C" & ToNodeNoAt).value
Lastrow = Lastrow - 1
Loop
CurrentRow = Lastrow
Lastrow = Cells(Rows.Count, "D").End(xlUp).Row
For insertNo = CurrentRow To Lastrow
Range("D" & insertNo).Select
If Range("D" & insertNo) = "" Then
' Finds DeadEnd Node if found then assign Zero
FindNode = Range("C" & insertNo).value
With Range("B8", Cells(Rows.Count, "B"))
Set rFind = .Cells.Find(What:=FindNode, _
LookIn:=xlValues, _
Lookat:=xlWhole)
If rFind Is Nothing Then
Range("D" & insertNo) = 0
Else:
Range("D" & insertNo) = AssignLoop
End If
End With
End If
Next insertNo
'Shared loop assignment
For j = 0 To NIPr(closedNode) - 1
For NodeInRange = CurrentRow To ToNodeNoAt
Range("B" & NodeInRange).Select
If AssignLoop <> 1 Then
If Range("B" & NodeInRange) = NPr(closedNode, j + 1) And Range("D" & NodeInRange) = AssignLoop And Range("E" & NodeInRange) = "" Then
TempAdd.Add (NPr(closedNode, j + 1))
End If
Else:
If Range("B" & NodeInRange) = NPr(closedNode, j + 1) Then TempAdd.Add (NPr(closedNode, j + 1))
End If
Next NodeInRange
NextNodeNo: Next j
'If TempAdd.Count = 0 Then
ReDim TempAdd2(TempAdd.Count - 1) '
For TostoreNode = 1 To TempAdd.Count
TempAdd2(TostoreNode - 1) = TempAdd.Item(TostoreNode)
Next TostoreNode
getLowest = Application.WorksheetFunction.Min(TempAdd2)
'
If getLowest <> 1 Then
For j = 8 To ToNodeNoAt
Range("B" & j).Select
Range("C" & j).Select
If Range("B" & j).value = getLowest And Range("C" & j).value = closedNode Then
'place the loop no as a shared loop
Range("E" & j).Select
Range("E" & j) = AssignLoop
If Range("D" & j) = Range("E" & j) Then
Range("E" & j) = 0
End If
End If
Next j
End If
AssignLoop = AssignLoop + 1
Set TempAdd = New Collection
End If
Next i
'Placing Zero where cells are blank
For i = 1 To IL
If Range("D" & i + Rw) = "" Then
Range("D" & i + Rw) = 0
End If
If Range("E" & i + Rw) = "" Then
Range("E" & i + Rw) = 0
End If
Next i
End SubThanks
