使用VBA代码在Excel中查找循环链接
我有一张下表。这表示Name列中的值之间的链接（或边）。
+-------+-------------------+
| 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 | |
+-------+-------------------+
如果我们依次在Name列中查找值，我想看看from列中的值是否作为前身存在。换句话说，我想看看是否有任何循环链接。
如何使用Excel中的VBA代码执行此操作？
在此示例中，HG, VB, OL, BN, PO具有循环链接。我只想突出显示“名称”列中的那些单元格。
一种方法是在单独的列中查找每一行的所有前辈，如下所示。
+-------+--------------------+-----------------------------------------------------------------------------------------------------------------------------------------------------+
| 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 | | |
+-------+--------------------+-----------------------------------------------------------------------------------------------------------------------------------------------------+
现在，在Name列的相应单元格中的predecessors列中搜索值将得到所需的结果。
如何在Excel中使用VBA代码实现这一目标？
编辑据我了解，这是网络问题。这是网络图，更加清晰。
EDIT2 这是我在 @GSerg 建议的方向上尝试（此处是VBA菜鸟）。卡在前辈的位置。遇到Argument not optional错误。
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
2 个答案:
答案 0 :(得分：1)
扩展我的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
现在您可以查看Worksheet.CircularReference，它也会很好地显示在工作表上：
答案 1 :(得分：1)
对于某些人来说这似乎很奇怪，但是这个问题确实让我很感兴趣，因为我以前从未遇到过需要编写递归代码的情况。
不确定它的效率如何，但是在我有限的测试中它可以立即起作用。将其放到新模块中，它应该可以正常运行。
Object o = ois.readObject();请注意，默认情况下字典区分大小写。如果您需要此代码以忽略大小写，请在顶部的声明中添加：
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
并更改此
option compare text
对此
Set DestinationByLocation = CreateObject("Scripting.Dictionary")
Set LoopLocations = CreateObject("Scripting.Dictionary")
感谢庄稼在没有发现循环的情况下识别错误；我更正了代码，以包括检查是否存在循环和可选的消息框输出。
相关问题
最新问题
- 我写了这段代码，但我无法理解我的错误
- 我无法从一个代码实例的列表中删除 None 值，但我可以在另一个实例中。为什么它适用于一个细分市场而不适用于另一个细分市场？
- 是否有可能使 loadstring 不可能等于打印？卢阿
- java中的random.expovariate()
- Appscript 通过会议在 Google 日历中发送电子邮件和创建活动
- 为什么我的 Onclick 箭头功能在 React 中不起作用？
- 在此代码中是否有使用“this”的替代方法？
- 在 SQL Server 和 PostgreSQL 上查询，我如何从第一个表获得第二个表的可视化
- 每千个数字得到
- 更新了城市边界 KML 文件的来源？