Option Explicit
Sub TEST6()
Dim ar, br, cr, i&, j&, k&, m&, n&, iNum&, iColSize&, strTemp$
Application.ScreenUpdating = False
With [A1].CurrentRegion
ar = Intersect(.Offset(0), .Offset(1)).Value
End With
ReDim br(1 To UBound(ar), 1 To UBound(ar) - 1)
iNum = [D1].Value
For i = 1 To UBound(ar)
strTemp = "," & ar(i, 1) & ","
m = 0
For j = 1 To UBound(ar)
If j <> i Then
n = 0
cr = Split(ar(j, 1), ",")
For k = 0 To UBound(cr)
If InStr(strTemp, "," & cr(k) & ",") Then
n = n + 1
If n = iNum Then Exit For
End If
Next k
If n = iNum Then m = m + 1: br(i, m) = ar(j, 1)
End If
Next j
If m > iColSize Then iColSize = m
Next i
[I2].Resize(10 ^ 3, 10 ^ 3).Clear
If iColSize Then [I2].Resize(UBound(br), iColSize) = br
Application.ScreenUpdating = True
Beep
End Sub
|