Home » excel » Find cyclic links in excel using VBA code

Find cyclic links in excel using VBA code

Posted by: admin May 14, 2020 Leave a comment

Questions:

I have a table as follows. This indicates links (or edges) between values in the Namecolumn.

+-------+-------------------+
| Name  | from              |
+-------+-------------------+
| G     | X; Y; HG; WP      |
| X     | U                 |
| Y     |                   |
| U     | V                 |
| V     |                   |
| K     | M; N              |
| M     |                   |
| N     |                   |
| G1    | G                 |
| G2    | G1                |
| G3    | G2                |
| G4a   | G3                |
| J     | G4a               |
| G4b   | G3                |
| G5b   | G4b               |
| H     | G5b               |
| R     | H; J              |
| R1    | R                 |
| R2    | R1                |
| O     | R2                |
| O1    | O                 |
| O2    | O1                |
| O3    | O2                |
| F     | H; K; TR          |
| P     | G; Z              |
| Z     |                   |
| HG    | VB; NH            |
| WP    |                   |
| TR    | Z                 |
| VB    | ICH; OL; NZ; LO   |
| NH    |                   |
| ICH   | NZ                |
| NZ    |                   |
| LO    |                   |
| OL    | TZ; HG            |
| TZ    |                   |
| BN    | WD; PO            |
| WD    | RZ; UX            |
| PO    | QA; IU; BV; MM; BN|
| RZ    |                   |
| UX    |                   |
| IU    |                   |
| QA    |                   |
| BV    |                   |
| MM    |                   |
+-------+-------------------+

I want to see if values in Namecolumn exist as predecessors if we sequentially look up values in fromcolumn. In other words I want to see if there are any cyclic links.

How to do this with VBA code in excel?

In this example HG, VB, OL, BN, PO have cyclic links. I want to highlight only those cells in column “Name”.

One way is to find all predecessors for each row in a separate column as follows.

+-------+--------------------+-----------------------------------------------------------------------------------------------------------------------------------------------------+
| GName | from               | predecessors                                                                                                                                        |
+-------+--------------------+-----------------------------------------------------------------------------------------------------------------------------------------------------+
| G     | X; Y; HG; WP       | X; U; V; Y; HG; VB; NH; ICH; NZ; LO; OL; TZ; WP                                                                                                     |
| X     | U                  | U; V                                                                                                                                                |
| Y     |                    |                                                                                                                                                     |
| U     | V                  | V                                                                                                                                                   |
| V     |                    |                                                                                                                                                     |
| K     | M; N               | M; N                                                                                                                                                |
| M     |                    |                                                                                                                                                     |
| N     |                    |                                                                                                                                                     |
| G1    | G                  | G; X; Y; HG; WP; U; VB; NH; V; ICH; NZ; LO; OL; TZ                                                                                                  |
| G2    | G1                 | G1; G; X; Y; HG; WP; U; VB; NH; V; ICH; NZ; LO; OL; TZ                                                                                              |
| G3    | G2                 | G2; G1; G; X; Y; HG; WP; U; VB; NH; V; ICH; NZ; LO; OL; TZ                                                                                          |
| G4a   | G3                 | G3; G2; G1; G; X; Y; HG; WP; U; VB; NH; V; ICH; NZ; LO; OL; TZ                                                                                      |
| J     | G4a                | G4a; G3; G2; G1; G; X; Y; HG; WP; U; VB; NH; V; ICH; NZ; LO; OL; TZ                                                                                 |
| G4b   | G3                 | G3; G2; G1; G; X; Y; HG; WP; U; VB; NH; V; ICH; NZ; LO; OL; TZ                                                                                      |
| G5b   | G4b                | G4b; G3; G2; G1; G; X; Y; HG; WP; U; VB; NH; V; ICH; NZ; LO; OL; TZ                                                                                 |
| H     | G5b                | G5b; G4b; G3; G2; G1; G; X; Y; HG; WP; U; VB; NH; V; ICH; NZ; LO; OL; TZ                                                                            |
| R     | H; J               | J; G4a; G3; G2; G1; G; X; Y; HG; WP; U; VB; NH; V; ICH; NZ; LO; OL; TZ; H; G5b; G4b; G3; G2; G1; G; X; Y; HG; WP; U; VB; NH; V; ICH; NZ; LO; OL; TZ |
| R1    | R                  | R; J; H; G4a; G5b; G3; G4b; G2; G1; G; X; Y; HG; WP; U; VB; NH; V; ICH; NZ; LO; OL; TZ                                                              |
| R2    | R1                 | R1; R; J; H; G4a; G5b; G3; G4b; G2; G1; G; X; Y; HG; WP; U; VB; NH; V; ICH; NZ; LO; OL; TZ                                                          |
| O     | R2                 | R2; R1; R; J; H; G4a; G5b; G3; G4b; G2; G1; G; X; Y; HG; WP; U; VB; NH; V; ICH; NZ; LO; OL; TZ                                                      |
| O1    | O                  | O; R2; R1; R; J; H; G4a; G5b; G3; G4b; G2; G1; G; X; Y; HG; WP; U; VB; NH; V; ICH; NZ; LO; OL; TZ                                                   |
| O2    | O1                 | O1; O; R2; R1; R; J; H; G4a; G5b; G3; G4b; G2; G1; G; X; Y; HG; WP; U; VB; NH; V; ICH; NZ; LO; OL; TZ                                               |
| O3    | O2                 | O2; O1; O; R2; R1; R; J; H; G4a; G5b; G3; G4b; G2; G1; G; X; Y; HG; WP; U; VB; NH; V; ICH; NZ; LO; OL; TZ                                           |
| F     | H; KTR             | K; M; N; H; G5b; G4b; G3; G2; G1; G; X; Y; HG; WP; U; VB; NH; V; ICH; NZ; LO; OL; TZ; TR; Z                                                         |
| P     | G; Z               | G; X; Y; HG; WP; U; VB; NH; V; ICH; NZ; LO; OL; TZ; Z                                                                                               |
| Z     |                    |                                                                                                                                                     |
| HG    | VB; NH             | VB; ICH; NZ; LO; OL; HG; TZ; NH; NH                                                                                                                 |
| WP    |                    |                                                                                                                                                     |
| TR    | Z                  | Z                                                                                                                                                   |
| VB    | ICH; OL; NZ; LO    | ICH; NZ; NZ; LO; OL; HG; TZ; VB; NH; ICH; NZ; LO                                                                                                    |
| NH    |                    |                                                                                                                                                     |
| ICH   | NZ                 | NZ                                                                                                                                                  |
| NZ    |                    |                                                                                                                                                     |
| LO    |                    |                                                                                                                                                     |
| OL    | TZ; HG             | HG; VB; NH; ICH; NZ; LO; OL; TZ; TZ                                                                                                                 |
| TZ    |                    |                                                                                                                                                     |
| BN    | WD; PO             | WD; RZ; UX; PO; BN; IU; QA; BV; MM; WD; RZ; UX                                                                                                      |
| WD    | RZ; UX             | RZ; UX                                                                                                                                              |
| PO    | QA; IU; BV; MM; BN | BN; WD; PO; RZ; UX; IU; QA; BV; MM; IU; QA; BV; MM                                                                                                  |
| RZ    |                    |                                                                                                                                                     |
| UX    |                    |                                                                                                                                                     |
| IU    |                    |                                                                                                                                                     |
| QA    |                    |                                                                                                                                                     |
| BV    |                    |                                                                                                                                                     |
| MM    |                    |                                                                                                                                                     |
+-------+--------------------+-----------------------------------------------------------------------------------------------------------------------------------------------------+

Now a search for values in Name column in the corresponding cell in the predecessors column will give the desired result.

How to achieve this using VBA code in excel?

EDIT As I understand this is a network problem. Here is the network diagram for more clarity.

enter image description here

EDIT2 Here is my attempt (VBA noob here) in the direction suggested by @GSerg. Stuck at fetching locations of predecessors. Getting Argument not optional error.

Public Function NetworkCyclicityCheck(node As String, col As Range) As String
Dim dicP As Object: Set dicP = CreateObject("Scripting.Dictionary")
If Trim(node) <> "" Then
For Each x In Split(cl.Value2, ";")
Key = Trim(x)
With Range
pcell = .Find(What:=Key, LookAt:=xlWhole, MatchCase:=False)
dicP(pcell) = dicP(pcell) & "," & cl.Address(0, 0)
Next x
End If
Set NetworkCyclicityCheck = dicP
Set dicP = Nothing
End Function
How to&Answers:

This might seem odd to some, but this question really intrigued me given I’d never come across a situation where I’ve needed to write recursive code before.

Not sure how efficient it is, but it works instantly in my limited testing. Drop this into a new module and it should run just fine.

Option Explicit Private DestinationByLocation As Object Sub Test() HighlightTheCycles Sheets("Sheet1").Range("A2:B46"), , True, True End Sub Public Sub HighlightTheCycles(ByVal TableRange As Range, Optional ClearExistingFill As Boolean = True, Optional OutputTheLoopPath As Boolean = False, Optional AlertIfNoCycles As Boolean = False) Dim InputData As Variant, OutputRange As Range Dim x As Long, y As Long, Temp As Variant Dim LoopLocations As Object Set DestinationByLocation = CreateObject("Scripting.Dictionary") Set LoopLocations = CreateObject("Scripting.Dictionary") DestinationByLocation.CompareMode = 1 LoopLocations.CompareMode = 1 'Set fill to 'no-fill' If ClearExistingFill Then If OutputTheLoopPath Then TableRange.Resize(TableRange.Rows.Count, 3).Interior.Pattern = xlNone Else TableRange.Interior.Pattern = xlNone End If End If 'Establish all possible destinations InputData = TableRange.Value For x = 1 To UBound(InputData, 1) If Len(InputData(x, 2)) > 0 Then Temp = Split(InputData(x, 2), ";") For y = 0 To UBound(Temp, 1) Temp(y) = Trim(Temp(y)) If DestinationByLocation.Exists(Temp(y)) Then DestinationByLocation(Temp(y)) = DestinationByLocation(Temp(y)) & ";" & InputData(x, 1) Else DestinationByLocation.Add Temp(y), InputData(x, 1) End If Next y End If Next x 'Look for loops Dim TempPath As Variant Temp = DestinationByLocation.Keys For x = 1 To UBound(Temp, 1) TempPath = TakeATrip(Temp(x)) If Right(TempPath, 3) = ";;;" Then TempPath = Split(Left(TempPath, Len(TempPath) - 3), ";") If TempPath(UBound(TempPath, 1)) = Temp(x) Then LoopLocations.Add Temp(x), TempPath End If End If Next x 'Mark the cells that result in a loop If LoopLocations.Count > 0 Then If OutputTheLoopPath Then 'Output the loop path found in a third column ReDim Temp(1 To UBound(InputData, 1), 1 To 1) For x = 1 To UBound(InputData, 1) If LoopLocations.Exists(InputData(x, 1)) Then If OutputRange Is Nothing Then Set OutputRange = TableRange.Cells(x, 1).Resize(1, 3) Else Set OutputRange = Union(OutputRange, TableRange.Cells(x, 1).Resize(1, 3)) End If Temp(x, 1) = Join(LoopLocations(InputData(x, 1)), ";") Temp(x, 1) = Replace(Right(Temp(x, 1), Len(Temp(x, 1)) - 1), ";", " ;") End If Next x TableRange.Cells(1, 1).Offset(0, 2).Resize(UBound(Temp, 1), 1).Value = Temp Else 'Do not output a third column For x = 1 To UBound(InputData, 1) If LoopLocations.Exists(InputData(x, 1)) Then If OutputRange Is Nothing Then Set OutputRange = TableRange.Cells(x, 1).Resize(1, 2) Else Set OutputRange = Union(OutputRange, TableRange.Cells(x, 1).Resize(1, 2)) End If End If Next x End If OutputRange.Interior.Color = RGB(255, 0, 0) ElseIf AlertIfNoCycles Then MsgBox _ "No cycles found in " & TableRange.Address(0, 0, , True), _ vbInformation End If End Sub Private Function TakeATrip(ByVal MyLocation As Variant, Optional ExistingPath As Variant = "") As Variant Dim MyJourneys As Variant, x As Long Dim MyPaths As Variant 'If no new destinations, record the trip If DestinationByLocation.Exists(MyLocation) Then If DestinationByLocation(MyLocation) = "" Then TakeATrip = ExistingPath & ";" & MyLocation Exit Function End If Else TakeATrip = ExistingPath & ";" & MyLocation Exit Function End If 'Prepare for multiple routes MyJourneys = Split(DestinationByLocation(MyLocation), ";") ReDim MyPaths(0 To UBound(MyJourneys)) For x = 0 To UBound(MyJourneys) If Len(MyJourneys(x)) > 0 Then If ExistingPath & ";" & MyLocation Like "*;" & MyJourneys(x) & ";*" Then TakeATrip = ExistingPath & ";" & MyLocation & ";" & MyJourneys(x) & ";;;" Exit Function 'a loop is found, we're done End If 'explore new found path MyPaths(x) = TakeATrip(MyJourneys(x), ExistingPath & ";" & MyLocation) End If If Right(MyPaths(x), 3) = ";;;" Then TakeATrip = MyPaths(x) Exit Function End If Next x TakeATrip = Join(MyPaths, "|") End Function 

PLEASE NOTE Dictionaries are case-sensitive by default. If you need this code to disregard case, add to your declarations at the top:

option compare text 

and change this

 Set DestinationByLocation = CreateObject("Scripting.Dictionary") Set LoopLocations = CreateObject("Scripting.Dictionary") 

to this

 Set DestinationByLocation = CreateObject("Scripting.Dictionary") Set LoopLocations = CreateObject("Scripting.Dictionary") DestinationByLocation.CompareMode = 1 LoopLocations.CompareMode = 1 

Thanks to Crops for identifying a bug when no loops found; I corrected the code to include a check for no loops and an optional message box output.

Answer:

Expanding on my comment,

Option Explicit Public Sub GenerateFormulas() Dim NodeNames As Range Set NodeNames = Range("A2:A56") ' Assumed that the "from" column is immediately to the right, ' and that the column after it is the one where the formulas will appear Dim dict As Object Set dict = CreateObject("Scripting.Dictionary") Dim c As Range For Each c In NodeNames.Cells dict(c.value) = c.Offset(0, 2).Address(False, False, xlA1) Next For Each c In NodeNames.Cells c.Offset(0, 2).Formula = ListToFormula(dict, c.Offset(0, 1).value) Next End Sub Private Function ListToFormula(ByVal dict As Object, ByVal list As String) As String Dim nodes() As String nodes = Split(list, ";") ListToFormula = "=""""" Dim i As Long For i = LBound(nodes) To UBound(nodes) ListToFormula = ListToFormula & " & " & dict(Trim$(nodes(i))) Next End Function 

Now you can look at Worksheet.CircularReference, and it will display nicely on the sheet too:

enter image description here