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.
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:
Tags: excelexcel, vba
