Option Explicit
Option Base 1
'//By JuanC - May. 2017
Sub mix_uplas()
Dim v As Variant, col As New Collection, col2 As New Collection
Dim i&, j&, k&, s$, n&, u&, m&, a$, b$, flg As Boolean
With Application
.ScreenUpdating = False
.EnableEvents = False
.Calculation = xlCalculationManual
End With
'//IMPORTANTE: El código no está optimizado!! (ni creo que sea 'la manera' de hacerlo, pero funciona...)
'//Al agregar más letras la cantidad de combinaciones crece exponencialmente
'//y el proceso se hace mucho más lento. Hasta 10 elementos va sin problemas...
' 1 2 3 4 5 6 7 8 9 10
v = Array("A", "B", "C", "D", "E", "F", "G", "H", "I", "J")n = UBound(v)
Range("A:Z").EntireColumn.ClearFor j = 1 To n
Range("A1").Offset(0, j - 1).Value = v(j)Next
For i = 1 To n
For j = i + 1 To n
s = v(i) & v(j)
col.Add s
Next
Next
On Error Resume Next
u = 2
begin:
m = col.Count
For i = 1 To n
For j = 1 To m
If VBA.Len(col.Item(j)) = u Then
If VBA.InStr(1, col.Item(j), v(i)) = 0 Then
s = v(i) & col.Item(j)
s = st(s)
col.Add s, s
End If
End If
Next
Next
u = u + 1
If u + 1 < n Then GoTo begin
m = col.Count
For i = 1 To m
a = col.Item(i)
For j = 1 To m
If i <> j Then
b = col.Item(j)
If VBA.Len(a) >= VBA.Len(b) Then
flg = False
For k = 1 To VBA.Len(a)
If VBA.InStr(1, b, VBA.Mid(a, k, 1)) > 0 Then
flg = True
Exit For
End If
Next
If Not flg Then
col.Add " " & a & " " & b & " "
End If
End If
End If
Next
Next
For j = 1 To n
col.Add v(i)
Next
m = col.Count
For i = 1 To m
s = col.Item(i)
For j = 1 To n
If VBA.InStr(1, s, v(j)) = 0 Then
s = s & " " & v(j) & " "
End If
Next
col.Add s
Next
u = col.Count
For i = 1 To u
v = VBA.Split(col.Item(i), " ")
Call SG(v)
s = ""
m = UBound(v)
For j = 1 To m
If VBA.Trim(v(j)) <> "" Then
s = s & VBA.Trim(v(j)) & "-"
End If
Next
If s <> "" Then
s = VBA.Left(s, VBA.Len(s) - 1)
col2.Add s, s
End If
Next
j = 0
m = col2.Count
For i = 1 To m
s = col2.Item(i)
s = VBA.Replace(s, "-", "")
If VBA.Len(s) >= n Then
s = (col2.Item(i))
v = VBA.Split(s, "-")
u = UBound(v)
For k = 0 To u
Range("A2").Offset(j, k).Value = v(k) Next
j = j + 1
End If
Next
With Application
.ScreenUpdating = True
.EnableEvents = True
.Calculation = xlCalculationAutomatic
End With
End Sub
Private Function st(str As String) As String
Dim i%, ln%, s() As String
ln = VBA.Len(str)
ReDim s(1 To ln) As String
For i = 1 To ln
s(i) = VBA.Mid(str, i, 1)
Next
Call SStr(s)
For i = 1 To ln
st = st & s(i)
Next
End Function
Private Sub SStr(ByRef ar() As String)
Dim i%, j%, s$
Dim m%, n%
m = UBound(ar)
n = LBound(ar)
For i = m To n Step -1
For j = n + 1 To i
If ar(j - 1) > ar(j) Then
s = ar(j - 1)
ar(j - 1) = ar(j)
ar(j) = s
End If
Next
Next
End Sub
Private Sub SG(ByRef ar As Variant)
Dim i%, j%, s$
Dim m%, n%
m = UBound(ar)
n = LBound(ar)
For i = m To n Step -1
For j = n + 1 To i
If VBA.Mid(ar(j - 1), 1, 1) > VBA.Mid(ar(j), 1, 1) Then
s = ar(j - 1)
ar(j - 1) = ar(j)
ar(j) = s
End If
Next
Next
End Sub
