Excel宏来遍历并识别目标字段的源

Question

有人能帮我用VBA Excel宏遍历回去找到源

这些都在excel表格

type   sub type    source  target
v4      v41        z2      z1
v4      v41        y4      y3
v3      v32        y3      y2
v3      v32        z1      b3
v3      v31        b4      b3
v2      v21        y2      y2
v2      v21        x3      x2
v2      v21        b3      b2
v2      v21        a3      a2
v1      v11        y2      y1
v1      v11        x2      x1
v1      v11        b2      b1
v1      v11        a2      a1

在上面的示例中，对于(v1)中的每个变量类型，我需要遍历并识别源变量

a1源是a3，路径是a1到a2, a2到a3但是对于b1，它有两个源b4和z2路径是b1到b2 b2到b3 b3到(b4和z1)和z1到z2，对于x1，它是x3路径是x1到x2 x2到x3对于y1，它是y5路径是y1到y2, y2到y3到y4, y4到y5

the code I tried.

Sub Macro1()
Dim prime_var   As String
Dim curr_var    As String
Dim prev_var    As String
Dim source_var  As String
row_count = 1
While Sheet1.Range("A" & row_count) <> ""
row_count = row_count + 1
Wend
row_count = row_count - 1
While row_count > 1
prime_var = Sheet1.Range("A" & row_count) + Sheet1.Range("B" & row_count)
curr_var = Sheet1.Range("A" & row_count - 1) + Sheet1.Range("B" & row_count - 1)
new_count = row_count
prev_var = Sheet1.Range("A" & row_count) + Sheet1.Range("B" & row_count)
source_var = Sheet1.Range("C" & row_count)

While new_count > 1
While curr_var = prev_var And new_count > 1
curr_var = Sheet1.Range("A" & new_count) + Sheet1.Range("B" & new_count)
new_count = new_count - 1
Wend
If source_var = Sheet1.Range("d" & new_count) Then
source_var = Sheet1.Range("c" & new_count)
End If
prev_var = Sheet1.Range("A" & new_count) + Sheet1.Range("B" & new_count)
curr_varCode
new_count = new_count - 1
prev_var = Sheet1.Range("A" & new_count) + Sheet1.Range("B" & new_count)
Wend
row_count = row_count - 1
Wend

结束子

问题是我无法确定两个源的解决方案(b1它将有两个源b4和z2)

Answer 1

这使用递归，字典包含每个目标的源集合，数组包含从目标到源的步骤。

Option Explicit
Dim dict As Object, key, rngOut As Range
Dim steps() As String, iStep As Integer
Sub macro1()

Dim ws As Worksheet
Dim iLastRow As Long, r As Long
Dim sSrc As String, sDest As String
Dim v As New Collection
Set dict = CreateObject("Scripting.Dictionary")

' input
Set ws = Sheet1
iLastRow = ws.Cells(Rows.Count, "A").End(xlUp).Row
For r = iLastRow To 2 Step -1
sSrc = Trim(ws.Cells(r, "C"))
sDest = Trim(ws.Cells(r, "D"))
If Not dict.exists(sDest) Then
dict.Add sDest, New Collection
End If
dict(sDest).Add sSrc
' v1s
If ws.Cells(r, "A") = "v1" Then v.Add sDest
Next
' process and output
Sheet2.Cells.Clear
Set rngOut = Sheet2.Range("A1")
ReDim steps(1 To 10)
For Each key In v
' first step
iStep = 1
steps(1) = key
Call traverse
Next
MsgBox "Done"
End Sub
Sub traverse()

Dim dest As String, n As Integer
' expand array if needed
If iStep > UBound(steps) Then
ReDim Preserve steps(1 To iStep + 10)
End If
steps(iStep) = key

If dict.exists(key) Then
' next steps
While dict(key).Count > 0
dest = dict(key).Item(1)
dict(key).Remove 1
' traverse forward
key = dest
iStep = iStep + 1
Call traverse
Wend
Else
' end of the line, output result
Set rngOut = rngOut.Offset(1)
rngOut = steps(1)
For n = 1 To iStep
rngOut.Offset(0, n - 1) = steps(n)
Next
' traverse back
iStep = iStep - 1
key = steps(iStep)
End If   
End Sub

Answer 2

您可以尝试以下代码(假设您的数据位于表1的A至D列):

Sub TravBack()
Dim lrow As Long, i As Long
Application.ScreenUpdating = False
With ThisWorkbook.Sheets(1)
lrow = .Cells(Rows.Count, 1).End(xlUp).Row

.Range("G2") = "=D2&"".""&COUNTIF($D$2:D2,D2)"
.Range("G2").AutoFill Destination:=.Range("G2:G" & lrow)

For i = 2 To lrow
If .Range("A" & i) = "v1" Then
.Range("E" & i) = .Range("C" & i)
Do
If Application.CountIf(.Range("D:D"), .Range("E" & i)) > 1 Then
.Range("F" & i) = .Range("E" & i) & ".2"
Do
.Range("F" & i) = .Range("C" & Application.Match(.Range("F" & i), .Range("G:G"), 0))
If .Range("C" & Application.Match(.Range("E" & i) & ".2", .Range("G:G"), 0)) = .Range("F" & i) Then Exit Do
Loop While IsError(Application.Match(.Range("F" & i), .Range("D:D"), 0)) = False
End If
.Range("E" & i) = .Range("C" & Application.Match(.Range("E" & i), .Range("D:D"), 0))
Loop While IsError(Application.Match(.Range("E" & i), .Range("D:D"), 0)) = False
End If
Next i
.Columns("G:G").Delete
End With
Application.ScreenUpdating = True
End Sub