Option Explicit ' Sub abc() Dim a, i, i1, i2, i3, i4, i5, m, n, t t = Timer ReDim b(1 To 10 ^ 6, 1 To 5) a = Range("b2:r" & [b2].End(xlDown).Row).Value ReDim d(UBound(a)) For i1 = 1 To UBound(a) Set d(i1) = CreateObject("scripting.dictionary") For i2 = 1 To UBound(a, 2) If Len(a(i1, i2)) = 0 Then Exit For d(i1)(a(i1, i2)) = d(i1)(a(i1, i2)) + 1 Next Next For i1 = 1 To 31 For i2 = i1 + 1 To 32 For i3 = i2 + 1 To 33 For i4 = i3 + 1 To 34 For i5 = i4 + 1 To 35 For i = 1 To UBound(a) n = 0 If d(i).exists(i1) Then n = n + 1 If d(i).exists(i2) Then n = n + 1 If d(i).exists(i3) Then n = n + 1 If d(i).exists(i4) Then n = n + 1 If d(i).exists(i5) Then n = n + 1 If n > 2 Then Exit For Next If i < UBound(a) + 1 Then Exit For m = m + 1 b(m, 1) = i1: b(m, 2) = i2: b(m, 3) = i3 b(m, 4) = i4: b(m, 5) = i5 Next i5, i4, i3, i2, i1 [y2].Resize(m, 5) = b Debug.Print Timer - t, m End Sub
Option Explicit ' Sub abc() Dim a, i, j, k, i1, i2, i3, i4, i5, i6, m, n, t t = Timer ReDim b(1 To 10 ^ 6, 1 To 6) a = Range("b2:s" & [b2].End(xlDown).Row).Value For i = 1 To UBound(a) For j = 17 To 1 Step -1 If Len(a(i, j)) Then a(i, 18) = j: Exit For Next Next For i = 1 To UBound(a) - 1 For j = i + 1 To UBound(a) If a(i, 18) < a(j, 18) Then For k = 1 To 18 i1 = a(i, k): a(i, k) = a(j, k): a(j, k) = i1 Next End If Next Next ReDim d(UBound(a)) For i1 = 1 To UBound(a) Set d(i1) = CreateObject("scripting.dictionary") For i2 = 1 To UBound(a, 2) If Len(a(i1, i2)) = 0 Then Exit For d(i1)(a(i1, i2)) = d(i1)(a(i1, i2)) + 1 Next Next For i1 = 1 To 28 For i2 = i1 + 1 To 29 For i3 = i2 + 1 To 30 For i4 = i3 + 1 To 31 For i5 = i4 + 1 To 32 For i6 = i5 + 1 To 33 For i = 1 To UBound(a) n = 0 If d(i).exists(i1) Then n = n + 1 If d(i).exists(i2) Then n = n + 1 If d(i).exists(i3) Then n = n + 1 If d(i).exists(i4) Then n = n + 1 If d(i).exists(i5) Then n = n + 1 If d(i).exists(i6) Then n = n + 1 If n > 3 Then Exit For Next If i < UBound(a) + 1 Then Exit For m = m + 1 b(m, 1) = i1: b(m, 2) = i2: b(m, 3) = i3 b(m, 4) = i4: b(m, 5) = i5: b(m, 6) = i6 Next i6, i5, i4, i3, i2, i1 [y2].Resize(m, 6) = b Debug.Print Timer - t, m End Sub