VBA 递归 上下阶料号查询

使用VBA，利用递归的方法查询上下阶料号

数据来源

tqrcbm0001

主件料件编号	元件料件编号
A	B
B	C
C	D

D>>C>>B>>A，“主件料号”处就是D所有的主件，这里包括了自己

在单元格中输入D,选中后运行宏程序“下阶料号查询作业_运行”，结果如下

A>>B>>C>>D，“元件料号”处就是A件所有的元件，这里也包括了自己

在单元格中输入A,选中后运行宏程序“上阶料号查询作业_运行”，结果如下

上阶料号

查询料号	主件料号	元件料号
A	A	A
A	A	B
A	B	C
A	C	D

VBA小程序

Option Explicit

Public MyExit As Boolean
Dim Daxcp012A As Object, Daxcp012B As Object


Function Tiptop() As String
    Dim rg As Range
    Set rg = ThisWorkbook.Sheets("说明").UsedRange.Find("运行程式名称")
    Tiptop = rg.Offset(0, 1).Value
End Function

Function MasterItemNum() As String
    Dim rg As Range
    Set rg = ThisWorkbook.Sheets("说明").UsedRange.Find("主件料号标题")
    MasterItemNum = rg.Offset(0, 1).Value
End Function

Function ComponentNum() As String
    Dim rg As Range
    Set rg = ThisWorkbook.Sheets("说明").UsedRange.Find("元件料号标题")
    ComponentNum = rg.Offset(0, 1).Value
End Function


Function ExtractString(ByVal sr As String) As String
    Dim rp As Object
    Set rp = CreateObject("vbscript.regexp")
    
    rp.Pattern = "[^A-Z^a-z^0-9^\u4e00-\u9fa5]"
    rp.Global = True
    ExtractString = rp.Replace(sr, "")
    
    Set rp = Nothing
End Function

Function Join1(TableRange As Range, Optional Delimiter As String = "|")
    Dim d As Object, x As Integer, y As Integer, i As Integer
    Dim arr1(), v As Variant, sr As String, arr2(), k As Integer
    Set d = CreateObject("scripting.dictionary")

    arr1 = TableRange.Value
    For x = 1 To UBound(arr1)
        If Not Rows(x + TableRange.Row - 1).Hidden Then
            For y = 1 To UBound(arr1, 2)
                If arr1(x, y) <> "" Then
                    For Each v In Split(arr1(x, y), Delimiter)
                        sr = Trim(CStr(v))
                        If sr <> "" Then
                            If Not d.exists(sr) Then
                                k = k + 1
                                d(sr) = k
                                ReDim Preserve arr2(1 To k)
                                arr2(k) = sr
                            End If
                        End If
                    Next v
                End If
            Next y
        End If
    Next x
    d.RemoveAll
    
    Join1 = Join(arr2, Delimiter)
End Function

Private Sub Data_axcp012(ByVal Part1 As String, ByVal Part2 As String)
    Dim x As Long, y As Long, ws As Worksheet, rg As Range, sr As String, sg As String, bl As Boolean
    Set Daxcp012A = CreateObject("scripting.dictionary")
    
    sr = Tiptop()
    Set ws = ThisWorkbook.Sheets(sr)
    Set rg = ws.UsedRange.Find("*")
    If rg Is Nothing Then
        MsgBox "错误！表【" & sr & "】中无数据！"
        MyExit = True
        Exit Sub
    End If
    Dim arr()
        arr = rg.CurrentRegion.Value
    Dim dZ As Object
        Set dZ = CreateObject("scripting.dictionary")
        For x = 1 To UBound(arr, 2)
            sr = arr(1, x)
            sr = ExtractString(sr)
            arr(1, x) = sr
            dZ(sr) = x
        Next x
    Dim a As Byte, b As Byte
        a = dZ(Part1)
        b = dZ(Part2)
   
    For x = 2 To UBound(arr)
        sr = Trim(arr(x, a))
        sg = Trim(arr(x, b))
        bl = True
        If sr = sg Then
            bl = False
        End If
        If sr = "ADJUST" Or sr = "DL+OH+SUB" Then
            bl = False
        End If
        If sg = "ADJUST" Or sg = "DL+OH+SUB" Then
            bl = False
        End If
        If bl Then
            If Not Daxcp012A.exists(sr) Then
                Set Daxcp012A(sr) = CreateObject("scripting.dictionary")
            End If
            Daxcp012A(sr)(sg) = ""
        End If
    Next x
End Sub


Sub 上阶料号查询作业_测试()
    MyExit = False
    Call Data_axcp012(MasterItemNum(), ComponentNum())
    If MyExit Then Exit Sub
    
    Dim sr As String
    
    sr = Application.InputBox("请输入主件料号！", "测试")
    If Daxcp012A.exists(sr) Then
        MsgBox Join(Daxcp012A(sr).KEYS, Chr(10)), vbOKOnly, "元件料号"
    Else
        MsgBox "料号不存在！"
    End If
End Sub


Sub 下阶料号查询作业_测试()
    MyExit = False
    Call Data_axcp012(ComponentNum(), MasterItemNum())
    If MyExit Then Exit Sub
    
    Dim sr As String
    
    sr = Application.InputBox("请输入元件料号！", "测试")
    If Daxcp012A.exists(sr) Then
        MsgBox Join(Daxcp012A(sr).KEYS, Chr(10)), vbOKOnly, "主件料号"
    Else
        MsgBox "料号不存在！"
    End If
End Sub


Sub 上阶料号查询作业_运行()
    MyExit = False
    Call Data_axcp012(MasterItemNum(), ComponentNum())
    If MyExit Then Exit Sub
    
    Dim arr() As String, k As Long, sr As String, v, y As Integer
    ReDim arr(1 To 300000, 1 To 3)
    Dim d As Object, Rng As Range, rg As Range
    Set d = CreateObject("scripting.dictionary")
    
    On Error Resume Next
    Set Rng = Application.InputBox(Prompt:="请选中单元格！", Title:="主件料号", Type:=8)
    On Error GoTo 0
    If Rng Is Nothing Then Exit Sub

    For Each rg In Rng
        sr = rg.Value
        If sr <> "" Then
            If Not d.exists(sr) Then
                d(sr) = ""
                Set Daxcp012B = CreateObject("scripting.dictionary")
                Call Shell_axcp012(sr)
                
                k = k + 1
                For y = 1 To UBound(arr, 2)
                    arr(k, y) = sr
                Next y
                If Daxcp012B.Count > 0 Then
                    For Each v In Daxcp012B.KEYS
                        k = k + 1
                        arr(k, 1) = sr
                        arr(k, 2) = Split(v, ";")(0)
                        arr(k, 3) = Split(v, ";")(1)
                    Next v
                End If
            End If
        End If
    Next rg
    d.RemoveAll

    With ThisWorkbook.Sheets("上阶料号")
        .Visible = -1
        .Select
        .AutoFilterMode = False
        .UsedRange.ClearContents
        .Cells(1, 1).Resize(1, UBound(arr, 2)) = Split("查询料号;主件料号;元件料号", ";")
        If k > 0 Then .Cells(2, 1).Resize(k, UBound(arr, 2)) = arr
    End With
End Sub


Sub 下阶料号查询作业_运行()
    MyExit = False
    Call Data_axcp012(ComponentNum(), MasterItemNum())
    If MyExit Then Exit Sub
    
    Dim arr() As String, k As Long, sr As String, v, y As Integer
    ReDim arr(1 To 200000, 1 To 3)
    Dim d As Object, Rng As Range, rg As Range
    Set d = CreateObject("scripting.dictionary")
    
    On Error Resume Next
    Set Rng = Application.InputBox(Prompt:="请选中单元格！", Title:="元件料号", Type:=8)
    On Error GoTo 0
    If Rng Is Nothing Then Exit Sub

    For Each rg In Rng
        sr = rg.Value
        If sr <> "" Then
            If Not d.exists(sr) Then
                d(sr) = ""
                Set Daxcp012B = CreateObject("scripting.dictionary")
                Call Shell_axcp012(sr)
                
                k = k + 1
                For y = 1 To UBound(arr, 2)
                    arr(k, y) = sr
                Next y
                If Daxcp012B.Count > 0 Then
                    For Each v In Daxcp012B.KEYS
                        k = k + 1
                        arr(k, 1) = sr
                        arr(k, 2) = Split(v, ";")(0)
                        arr(k, 3) = Split(v, ";")(1)
                    Next v
                End If
            End If
        End If
    Next rg
    d.RemoveAll

    With ThisWorkbook.Sheets("下阶料号")
        .Visible = -1
        .Select
        .AutoFilterMode = False
        .UsedRange.ClearContents
        .Cells(1, 1).Resize(1, UBound(arr, 2)) = Split("查询料号;元件料号;主件料号", ";")
        If k > 0 Then .Cells(2, 1).Resize(k, UBound(arr, 2)) = arr
    End With
End Sub


Private Sub Shell_axcp012(ByVal sr As String)
    Dim v, sg As String
    
    If Daxcp012A.exists(sr) Then
        For Each v In Daxcp012A(sr).KEYS
            sg = sr & ";" & CStr(v)
            If Not Daxcp012B.exists(sg) Then
                Daxcp012B(sg) = ""
                Call Shell_axcp012(CStr(v))
            End If
        Next v
    End If
End Sub