excel中怎样让一列数据中与某个单元格有一个相同的数字的数提取出来?

-------A-------B-------
1 123
2 345
3 890 123
4 247 345
在A1：A3这个范围内找出与A4有一个相同数字的提取出来放在B列。要按从下到上。下面对齐，原来在A列中位置在下面的放在下面。原来在上面的放在上面。如：345是第一个符合要求的数放面最下面，123是第个符合要求的数放在345的上面。谢谢！

这个么，用宏可以么，比较简单

Sub t()
    Dim i, j, k, p
    Dim brr(), crr()
    Set dic = CreateObject("scripting.dictionary")
    i = Selection.Cells(1, 1).Row
    j = Selection.Cells(1, 1).Column
    k = Selection.Cells.Count
    arr = Selection
    ReDim brr(1 To UBound(arr, 1))
    ReDim crr(1 To UBound(arr, 1))
    p = 1
    For n = UBound(arr, 1) - 1 To 1 Step -1
        For m = 1 To Len(arr(UBound(arr, 1), 1))
            If InStr(arr(n, 1), Mid(arr(UBound(arr, 1), 1), m, 1)) <> 0 Then
                brr(p) = arr(n, 1)
                p = p + 1
                Exit For
            End If
        Next
    Next
    For m = 1 To UBound(arr, 1)
        crr(m) = brr(UBound(arr, 1) - m + 1)
    Next
    Selection.Offset(0, 1) = Application.Transpose(crr)
End Sub

选中区域，你这里选中A1:A4，然后运行宏就可以了。有什么问题请继续追问

追问

有两个问题，1是请你在代码中定个范围如A1：A4。不要去选中。2是单元格中第一个数字是0时，提出来后0不在了。

追答

把范围定死了不就没有适应性了么，这样你想排多少都可以啊，0的问题我待会看下，现在比较忙，稍等

追问

你定个可自己修改的范围啊。如你的代码中是A1：A4。我也可以改为A1：A100。

追答Sub t()
    Dim p
    Dim rng as range 
    Dim brr(), crr()
    Set rng = Range("A1:A10") '这里改范围 
    arr = rng 
    ReDim brr(1 To UBound(arr, 1))
    ReDim crr(1 To UBound(arr, 1))
    p = 1
    For n = UBound(arr, 1) - 1 To 1 Step -1
        For m = 1 To Len(arr(UBound(arr, 1), 1))
            If InStr(arr(n, 1), Mid(arr(UBound(arr, 1), 1), m, 1)) <> 0 Then
                brr(p) ="'" & arr(n, 1)
                p = p + 1
                Exit For
            End If
        Next
    Next
    For m = 1 To UBound(arr, 1)
        crr(m) = brr(UBound(arr, 1) - m + 1)
    Next
    rng.Offset(0, 1) = Application.Transpose(crr)
End Sub

 这样呢？

0不在的问题，是单元格格式照成的……excel自动会把0去掉

我强制转换成了文本型，你看下可以么。

追问

还有点问题：你在最后一个单元格输入277，另一个单元格输入072。结果072也提出来了。而072与277有两个相同的数字是不符合要求的。

追答

你的问题是有一个相同数字啊，不是只有一个啊……自己没说清楚。

Sub t()
    Dim p,t
    Dim rng as range 
    Dim brr(), crr()
    Set rng = Range("A1:A10") '这里改范围 
    arr = rng 
    ReDim brr(1 To UBound(arr, 1))
    ReDim crr(1 To UBound(arr, 1))
    p = 1
    For n = UBound(arr, 1) - 1 To 1 Step -1
        t=0
        For m = 1 To Len(arr(UBound(arr, 1), 1))
            If InStr(arr(n, 1), Mid(arr(UBound(arr, 1), 1), m, 1)) <> 0 Then
                t=t+1
            End If
            if t=1 then
                brr(p) ="'" & arr(n, 1)
                p = p + 1 
            end if  
        Next
    Next
    For m = 1 To UBound(arr, 1)
        crr(m) = brr(UBound(arr, 1) - m + 1)
    Next
    rng.Offset(0, 1) = Application.Transpose(crr)
End Sub

追问

运行时下标越界。

追答Sub t()
    Dim p,t
    Dim rng as range 
    Dim brr(), crr()
    Set rng = Range("A1:A10") '这里改范围 
    arr = rng 
    ReDim brr(1 To UBound(arr, 1))
    ReDim crr(1 To UBound(arr, 1))
    p = 1
    For n = UBound(arr, 1) - 1 To 1 Step -1
        t=0
        For m = 1 To Len(arr(UBound(arr, 1), 1))
            If InStr(arr(n, 1), Mid(arr(UBound(arr, 1), 1), m, 1)) <> 0 Then
                t=t+1
            End If
        Next
        if t=1 then
            brr(p) ="'" & arr(n, 1)
            p = p + 1 
        end if   
    Next
    For m = 1 To UBound(arr, 1)
        crr(m) = brr(UBound(arr, 1) - m + 1)
    Next
    rng.Offset(0, 1) = Application.Transpose(crr)
End Sub

温馨提示：内容为网友见解，仅供参考

当前网址：https://11.t2y.org/zz/fv8mf88f77spv7p8vvq.html