Option Explicit Sub abc() Dim a, i, j, m, n a = [a1:a16] ReDim b(1 To 8, 1 To 15 * 3) For i = 1 To 16 For j = i + 1 To 16 m = m + 1 b(m, n + 1) = a(i, 1): b(m, n + 2) = a(j, 1) If m = 8 Then m = 0: n = n + 3 Next Next [b2].Resize(UBound(b), UBound(b, 2)) = b End Sub
Option Explicit Sub abc() Dim a, i, j, d, m, n a = [a1:a16].Value Set d = CreateObject("scripting.dictionary") ReDim b(1 To 120, 1 To 2) For i = 1 To UBound(a) - 1 For j = i + 1 To UBound(a) m = m + 1 b(m, 1) = a(i, 1): b(m, 2) = a(j, 1) Next Next ReDim c(1 To 8, 15 * 2) For j = 1 To 15 m = 0 For i = 1 To 120 If Len(b(i, 1)) Then If Not d.exists(b(i, 1)) And Not d.exists(b(i, 2)) Then m = m + 1 c(m, n + 1) = b(i, 1) & "-" & b(i, 2) d(b(i, 1)) = 1: d(b(i, 2)) = 1 b(i, 1) = Empty If m = 8 Then Exit For End If End If Next n = n + 2: d.RemoveAll Next [c1].Resize(UBound(c), UBound(c, 2)) = c End Sub