Option Explicit
Option Private Module
'//By JuanC - 26 May. 2012
Private Const cSEP = ";" '//El separador NO puede ser una coma (,)
Sub main()
Dim s$, i%, p%, t$
Dim rng As Range, c As Range
Dim m(4) As String
On Error Resume Next
Application.ScreenUpdating = False
Set rng = Range("A1:A100")For Each c In rng
s = VBA.LCase(c.Text)
s = fClear(s)
If s = "" Then GoTo siga
p = 0
For i = 0 To 3
m(i) = ""
m(i) = VBA.Split(s, " ")(i)
If m(i) <> "" Then p = p + 1
Next
If p = 1 Then
Call AddList(c.Offset(0, 1), Excel.WorksheetFunction.Proper(s) & ",")
ElseIf p = 2 Then
t = VBA.Mid(s, 1, VBA.InStr(1, s, " ") - 1) & "; " & VBA.Trim(VBA.Mid(s, VBA.InStr(1, s, " ") + 1, VBA.Len(s))) & ","
t = t & VBA.Trim(VBA.Mid(s, VBA.InStr(1, s, " ") + 1, VBA.Len(s)) & "; " & VBA.Mid(s, 1, VBA.InStr(1, s, " ") - 1))
Call AddList(c.Offset(0, 1), Excel.WorksheetFunction.Proper(t))
ElseIf p = 3 Then
Call g3(c, m(0), m(1), m(2))
ElseIf p = 4 Then
Call g4(c, m(0), m(1), m(2), m(3))
Else
c.Offset(0, 1).Value = ""
End If
siga:
Next
Application.ScreenUpdating = True
MsgBox "Proceso finalizado!"
End Sub
Private Sub g3(rngPivot As Range, a$, b$, c$)
Dim v As Variant, i%, j%, m As Variant, s$
Dim lst() As Variant, n%
m = Array("A.BC", "B.AC", "C.AB", "BA.C", "CA.B", "CB.A")For j = 0 To UBound(m)
v = cmb3(m(j), a, b, c)
For i = 0 To 1
ReDim Preserve lst(n)
lst(n) = v(i)
n = n + 1
Next
Next
Call fQuickSort(lst, 0, UBound(lst))
s = ""
For i = 0 To UBound(lst)
s = s & "," & Excel.WorksheetFunction.Proper(lst(i))
Next
Call AddList(rngPivot.Offset(0, 1), VBA.Mid(s, 2))
Erase lst
End Sub
Private Sub g4(rngPivot As Range, a$, b$, c$, d$)
Dim v As Variant, i%, j%, m As Variant, s$
Dim lst() As Variant, n%
m = Array("A.BCD", "A.BDC", "A.CBD", "A.CDB", "A.DBC", "A.DCB", "B.ACD", "B.ADC", "B.CAD", "B.CDA", "B.DAC", "B.DCA", _ "C.ABD", "C.ADB", "C.BAD", "C.BDA", "C.DAB", "C.DBA", "D.ABC", "D.ACB", "D.BAC", "D.BCA", "D.CAB", "D.CBA", _
"AB.CD", "AB.DC", "AC.BD", "AC.DB", "AD.BC", "AD.CB", "BA.CD", "BA.DC", "BC.DA", "BD.CA", "CB.DA", "DB.CA")
n = 0
For j = 0 To UBound(m)
v = cmb4(m(j), a, b, c, d)
For i = 0 To 1
ReDim Preserve lst(n)
lst(n) = v(i)
n = n + 1
Next
Next
Call fQuickSort(lst, 0, UBound(lst))
s = ""
For i = 0 To UBound(lst)
s = s & "," & Excel.WorksheetFunction.Proper(lst(i))
Next
Call AddList(rngPivot.Offset(0, 1), VBA.Mid(s, 2))
Erase lst
End Sub
Private Function cmb3(s As Variant, a$, b$, c$) As Variant
Dim v(2) As String
Dim t$
t = VBA.Replace(s, "A", a & " ")
t = VBA.Replace(t, "B", b & " ")
t = VBA.Replace(t, "C", c & " ")
t = VBA.Replace(t, ".", cSEP)
t = VBA.Trim(VBA.Replace(t, " " & cSEP, cSEP & " "))
t = VBA.Replace(t, " ", " ")
v(0) = (t)
v(1) = VBA.Trim(VBA.Mid(t, VBA.InStr(1, t, cSEP) + 1, VBA.Len(t)) & cSEP & " " & VBA.Mid(t, 1, VBA.InStr(1, t, cSEP) - 1))
cmb3 = v
End Function
Private Function cmb4(s As Variant, a$, b$, c$, d$) As Variant
Dim v(2) As String
Dim t$
t = VBA.Replace(s, "A", a & " ")
t = VBA.Replace(t, "B", b & " ")
t = VBA.Replace(t, "C", c & " ")
t = VBA.Replace(t, "D", d & " ")
t = VBA.Replace(t, ".", cSEP)
t = VBA.Trim(VBA.Replace(t, " " & cSEP, cSEP & " "))
t = VBA.Replace(t, " ", " ")
v(0) = (t)
v(1) = VBA.Trim(VBA.Mid(t, VBA.InStr(1, t, cSEP) + 1, VBA.Len(t)) & cSEP & " " & VBA.Mid(t, 1, VBA.InStr(1, t, cSEP) - 1))
cmb4 = v
End Function
Private Sub AddList(rng As Range, s$)
On Error Resume Next
With rng.Validation
.Delete
.Add Type:=xlValidateList, AlertStyle:=xlValidAlertStop, Operator:=xlBetween, Formula1:=(s)
.IgnoreBlank = True
.InCellDropdown = True
.InputTitle = ""
.ErrorTitle = ""
.InputMessage = ""
.ErrorMessage = ""
.ShowInput = True
.ShowError = True
End With
rng.Value = VBA.Mid(s, 1, VBA.InStr(1, s, ",") - 1)
End Sub
Private Function fClear(ByVal s As String) As String
Dim i%
s = VBA.Replace(s, ",", "")
s = VBA.Replace(s, ".", "")
s = VBA.Replace(s, ";", "")
s = VBA.Replace(s, "-", "")
s = VBA.Replace(s, "_", "")
For i = 20 To 2 Step -1
s = VBA.Replace(s, String(i, " "), " ")
Next
fClear = s
End Function
Private Sub fQuickSort(vArray As Variant, l As Long, R As Long)
Dim i As Long, j As Long
Dim X, Y
i = l
j = R
X = vArray((l + R) / 2)
Do While (i <= j)
DoEvents
Do While (vArray(i) < X And i < R)
i = i + 1
Loop
Do While (X < vArray(j) And j > l)
j = j - 1
Loop
If (i <= j) Then
Y = vArray(i)
vArray(i) = vArray(j)
vArray(j) = Y
i = i + 1
j = j - 1
End If
Loop
If (l < j) Then fQuickSort vArray, l, j
If (i < R) Then fQuickSort vArray, i, R
End Sub
