Not too sure, but my macro yield 1761 result rows while John's yield 106 rows :
Sub test()
Dim a, b, vow(1 To 6) As String * 1, i As Long, j As Long, k As Long, p As Long, s1 As String, s2 As String, v, z As New Collection
For Each v In Array("A", "E", "I", "O", "U", "Y")
i = i + 1
vow(i) = v
Next v
With Sheets("Sheet1")
a = .Range("A1").CurrentRegion.Columns("A").Value
ReDim b(1 To UBound(a, 1) * 6, 1 To 7)
For i = 1 To UBound(a, 1)
s1 = a(i, 1)
For j = 1 To Len(a(i, 1))
s2 = Mid$(s1, j, 1)
For k = 1 To 6
If s2 = vow(k) Then
s2 = s1
Mid$(s2, j, 1) = "|"
On Error Resume Next
z.Add Key:=s2, Item:=z.Count + 1
On Error GoTo 0
p = z(s2)
b(p, k) = s1
b(p, 7) = b(p, 7) + 1
Exit For
End If
Next k
Next j
Next i
p = 0
For i = 1 To z.Count
If b(i, 7) >= 2 Then
p = p + 1
For j = 1 To 6
b(p, j) = b(i, j)
Next j
End If
Next i
.Range("D4").Resize(p, 6).Value = b
End With
End Sub
Bookmarks