Генерация всех возможных словосочетаний из столбцов

Sub bb()
Dim i&, j&, n&, p&, q&, x, v(), s$
v = Selection.Value
ReDim slova$(0 To UBound(v) * UBound(v, 2))
For Each x In v
  If Not IsEmpty(x) Then slova(i) = Trim$(Replace$(x, ChrW$(160), "")): i = i + 1
Next
ReDim v(0 To 2 ^ i - 1, 1 To 1)
For i = 3 To UBound(v)
  j = i 'число для разбора на биты
  n = 0 'номер слова
  p = 0 'число единиц в двоичном представлении
  s = ""
  Do While j
    If j Mod 2 Then s = s & " " & slova(n): p = p + 1
    j = j \ 2
    n = n + 1
  Loop
  If p > 1 Then v(q, 1) = Mid(s, 2): q = q + 1
Next
Sheets.Add.Cells(1, 1).Resize(q).Value = v
 
End Sub

Sub TwoWords()
Dim v(), i&, j&, k&, n&, p&, q&
  v = Selection.Value
  ReDim m&(1 To UBound(v, 2))
  With WorksheetFunction
    For i = 1 To UBound(m)
      m(i) = .CountA(.Index(v, 0, i))
    Next
    ReDim s$(1 To .Average(m) ^ 2 * .Combin(UBound(m), 2), 0 To 0)
  End With
  For i = 1 To UBound(m) - 1
    For j = i + 1 To UBound(m)
      For k = 1 To m(i)
        For q = 1 To m(j)
          n = n + 1
          s(n, 0) = v(k, i) & " " & v(q, j)
  Next q, k, j, i
  Worksheets.Add.Cells(1, 1).Resize(n).Value = s
Debug.Print UBound(s); n
End Sub