这个么，用宏可以么，比较简单
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