很简单，稍后把VBA源代码贴上来。
试试下面这个代码
Sub zzllrr()
Dim i, v, v2, arr, arr2, arr3, n
v = Range("A3357").Value
arr = Left(v, 1)
If InStr(arr, Mid(v, 2, 1)) < 1 Then
arr = arr & Mid(v, 2, 1)
End If
If InStr(arr, Right(v, 1)) < 1 Then
arr = arr & Right(v, 1)
End If
arr3 = ""
For i = 2 To 3356
v2 = Range("A" & i).Value
arr2 = Left(v2, 1)
If InStr(arr2, Mid(v2, 2, 1)) < 1 Then
arr2 = arr2 & Mid(v2, 2, 1)
End If
If InStr(arr2, Right(v2, 1)) < 1 Then
arr2 = arr2 & Right(v2, 1)
End If
n = 0
For j = 1 To Len(arr2)
n = IIf(InStr(arr, Mid(arr2, j, 1)) > 0, 1, 0)
Next j
If n = 1 Then
arr3 = arr3 & "," & v2
End If
Next i
arr3 = Split(Mid(arr3, 2, Len(arr3) - 1), ",")
Range("D" & (3357 - UBound(arr3)) & ":D3357") = WorksheetFunction.Transpose(arr3)
End Sub
Option Base 1
Sub 提取满足条件的数()
Dim arr, drr, d As Object, d1 As Object
Range("D2:D20").ClearContents
Application.ScreenUpdating = False
Set d = CreateObject("scripting.dictionary")
For i = 1 To Len([A19])
If Not d.exists(Mid([A19], i, 1)) Then d.Add Mid([A19], i, 1), ""
Next
arr = [A2:A18]
For i = UBound(arr) To 1 Step -1
Set d1 = CreateObject("scripting.dictionary")
For j = 1 To Len(arr(i, 1))
If Not d1.exists(Mid(arr(i, 1), j, 1)) Then
d1.Add Mid(arr(i, 1), j, 1), ""
Else
If d.exists(Mid(arr(i, 1), j, 1)) Then GoTo 100
End If
Next
k = 0
drr = d1.keys
For j = 0 To d1.Count - 1
If d.exists(drr(j)) Then k = k + 1
Next
If k = 1 Then
If [D19] = "" Then [D19] = Cells(i + 1, "A") Else Range("D1").End(xlDown).Offset(-1, 0) = Cells(i + 1, "A")
End If
100:
Set d1 = Nothing: Erase drr
Next
Application.ScreenUpdating = True
End Sub
详请见附件。
自己把代码里的单元格改为 你的A3357
代码如下，详见附件。
Private Sub CommandButton1_Click()
Range("D:D").ClearContents
Sd = [A3357]
m = 3357
For i = 3356 To 2 Step -1
S = Sd: n = 0
Rd = Range("A" & i).Text
For j = 1 To 3
R1 = Mid(Rd, j, 1)
If InStr(S, R1) > 0 Then
n = n + 1
S = Replace(S, R1, "", , 1)
End If
Next
If n = 1 Then
Range("D" & m) = Rd
m = m - 1
End If
Next
End Sub
在D3357单元格输入公式：
=INDEX(A:A,LARGE(IF(MMULT(1*ISNUMBER(FIND(MID(A$2:A$3356,COLUMN(A:C),1),A$3357)),ROW($1:$3)^0)=1,ROW($2:$3356),1),3358-ROW()))
公式以CTRL+SHIFT+ENTER三键结束。
将公式向上复制。
内容全部来源于网络收集，如有侵权，请联系网站删除：QQ：24596024