[已解决]一对多查找

mengcao888

具体要求在附件中，麻烦各位大神了。

最佳答案

月排行榜 / 总排行榜

哥儿-

2022-9-17 13:59

改了一下代码。测试一下
Sub test()
    Dim i%, j%, dic As Object, d As Object
    Dim dataArr, brr, n
    Set dic = CreateObject("scripting.dictionary")
    Set d = CreateObject("scripting.dictionary")
    dataArr = ActiveSheet.[a2].CurrentRegion
    For i = 3 To UBound(dataArr)
        For j = 2 To UBound(dataArr, 2) Step 2
            If Len(dataArr(i, j)) > 0 Then
                d(dataArr(i, j)) = dataArr(i, 1)
                If dic.exists(dataArr(i, 1)) Then
                    dic(dataArr(i, 1)) = dic(dataArr(i, 1)) & " " & dataArr(i, j)
                Else
                    dic(dataArr(i, 1)) = dataArr(i, j)
                End If
            End If
        Next j
    Next
    Erase dataArr
    If dic.exists(Range("B17").Value) Then
        dataArr = Split(dic(Range("b17").Value))
        ReDim brr(1 To UBound(dataArr) + 1, 1 To 2)
        For i = 0 To UBound(dataArr)
            n = n + 1
            brr(n, 1) = i + 1
            brr(n, 2) = dataArr(i)
         Next
    Else
        dataArr = Split(dic(d(Range("b17").Value)))
        ReDim brr(1 To UBound(dataArr) + 2, 1 To 2)
        n = 1
        For i = 0 To UBound(dataArr)
            If Val(dataArr(i)) <> Range("b17").Value Then
                brr(1, 2) = d(Range("b17").Value)
                brr(1, 1) = 1
                n = n + 1
                brr(n, 1) = n
                brr(n, 2) = dataArr(i)
            End If
        Next
    End If
    [a20:b100].ClearContents
    Range("A20").Resize(UBound(brr), 2) = brr
  End Sub

跳转到最佳答案楼层

哥儿-

仅供参考……
Sub test()
    Dim i%, j%, dic As Object, d As Object
    Dim dataArr, brr, n
    Set dic = CreateObject("scripting.dictionary")
    Set d = CreateObject("scripting.dictionary")
    dataArr = ActiveSheet.[a2].CurrentRegion
    For i = 3 To UBound(dataArr)
        For j = 2 To UBound(dataArr, 2) Step 2
            If Len(dataArr(i, j)) > 0 Then
                d(dataArr(i, j)) = dataArr(i, 1)
                If dic.exists(dataArr(i, 1)) Then
                    dic(dataArr(i, 1)) = dic(dataArr(i, 1)) & " " & dataArr(i, j)
                Else
                    dic(dataArr(i, 1)) = dataArr(i, j)
                End If
            End If
        Next j
    Next
    Erase dataArr
    If dic.exists(Range("B17").Value) Then
        dataArr = Split(dic(Range("b17").Value))
    Else
        dataArr = Split(dic(d(Range("b17").Value)))
    End If
    ReDim brr(1 To UBound(dataArr) + 1, 1 To 2)
    For i = 0 To UBound(dataArr)
        n = n + 1
        brr(n, 1) = i + 1
        brr(n, 2) = dataArr(i)
    Next
    [a20:b100].ClearContents
    Range("A20").Resize(UBound(brr), 2) = brr
   
End Sub

mengcao888

非常感谢，在适用中。

mengcao888

上述代码运行了，发现有以下问题，具体情况见附件

哥儿-

改了一下代码。测试一下
Sub test()
    Dim i%, j%, dic As Object, d As Object
    Dim dataArr, brr, n
    Set dic = CreateObject("scripting.dictionary")
    Set d = CreateObject("scripting.dictionary")
    dataArr = ActiveSheet.[a2].CurrentRegion
    For i = 3 To UBound(dataArr)
        For j = 2 To UBound(dataArr, 2) Step 2
            If Len(dataArr(i, j)) > 0 Then
                d(dataArr(i, j)) = dataArr(i, 1)
                If dic.exists(dataArr(i, 1)) Then
                    dic(dataArr(i, 1)) = dic(dataArr(i, 1)) & " " & dataArr(i, j)
                Else
                    dic(dataArr(i, 1)) = dataArr(i, j)
                End If
            End If
        Next j
    Next
    Erase dataArr
    If dic.exists(Range("B17").Value) Then
        dataArr = Split(dic(Range("b17").Value))
        ReDim brr(1 To UBound(dataArr) + 1, 1 To 2)
        For i = 0 To UBound(dataArr)
            n = n + 1
            brr(n, 1) = i + 1
            brr(n, 2) = dataArr(i)
         Next
    Else
        dataArr = Split(dic(d(Range("b17").Value)))
        ReDim brr(1 To UBound(dataArr) + 2, 1 To 2)
        n = 1
        For i = 0 To UBound(dataArr)
            If Val(dataArr(i)) <> Range("b17").Value Then
                brr(1, 2) = d(Range("b17").Value)
                brr(1, 1) = 1
                n = n + 1
                brr(n, 1) = n
                brr(n, 2) = dataArr(i)
            End If
        Next
    End If
    [a20:b100].ClearContents
    Range("A20").Resize(UBound(brr), 2) = brr
  End Sub

哥儿-

附上附件。另外提几点建议：
其一：要求：将“表1”中的任意编号输入到“B16”单元格后，自动将该“编号”的所有替代号按“表2”显示出来，如：将编号“84138305”输入“B16"单元格后，自动将该“编号”的所有替代编号按下表方式显示出来。
问题表述不清，不仔细看模拟结果，会错漏掉还需要返回编号，以为只需要返回替换编号。当然这也是我自己疏忽的原因。
其二：追问的时候，是你发现所存在的问题，因此需要你表述清楚，哪里不符合要求，而不是截图打上几个问号？，画上箭头我就能理解你的意思，看图写作文我不擅长。我理解不了你的意思。有问题只需直接、直观的表述出来即可。能帮的都会帮。

mengcao888

大神所说既是，确实表述不清晰。刚刚运行了，非常好，谢谢了。