Macro para combinar diferentes posibilidades
Espero que me puedan ayudar, he tratado de hacer eso pero no consigo dar con una fórmula que pueda, pensé en macro pero no sé como poder hacerla.
Necesito hacer una macro que pueda crear todas las combinaciones posibles para una cantidad de datos.
Se me ocurre poner cada valor en una variable pero no sé (o desconozco la funcionalidad en vb) para poder combinar las variables sin repetirlas, además es probable que se agreguen nuevas variables al listado (por ejemplo más frutas)
Tengo los siguientes datos agrupados (tabla azul), y necesito crear opción con todas las combinatorias posibles (tabla turquesa)
¿Existe alguna funcionalidad para hacer eso? ¿En macro o combinando algunas fórmulas?
Atento a sus comentarios.
2 Respuestas
Por fórmula esta bien difícil hacerlo es a fuerza macros y aun así tiene su chiste programarla por suerte lo que pides no es tan complicado, este es el resultado de la macro
Puedes quitar o agregar elementos a la tabla principal y estos serán considerados a la hora de correr la macro
Sub combinar()
Dim unicos As New Collection
Set datos = Range("tabla2")
Set funcion = WorksheetFunction
With datos
For i = 1 To .Columns.Count
elementos = funcion.CountA(.Columns(i))
If i = 1 Then multiplo = elementos
If i > 1 Then multiplo = multiplo * elementos
Next i
Set tabla = .Rows(.Rows.Count + 4).Resize(multiplo, .Columns.Count)
matriz = tabla
For i = 1 To multiplo * 15
For j = 1 To .Columns.Count
cantidad = funcion.CountA(.Columns(j))
aleatorio = funcion.RandBetween(1, cantidad)
nombre = .Cells(aleatorio, j)
If j = 1 Then concatena = nombre
If j > 1 Then concatena = concatena & "," & nombre
Next j
On Error Resume Next
unicos.Add concatena, CStr(concatena)
On Error GoTo 0
Next i
Set tabla2 = .Columns(.Columns.Count + 2).Resize(multiplo, 1)
With tabla2
For i = 1 To unicos.Count: .Cells(i, 1) = unicos.Item(i): Next i
.Sort key1:=Range(.Columns(1).Address), order1:=xlAscending
For i = 1 To multiplo
combi = .Cells(i, 1): separa = Split(combi, ",")
For j = 1 To UBound(separa) + 1
matriz(i, j) = separa(j - 1)
Next j
Next i
End With
Range(tabla.Address) = matriz: tabla2.Clear
End With
End Sub
Olvide mencionar como vi que creaste una tabla solo cambia en la macro el nombre de tabla2 por el nombre de tu tabla
Si tienes un bucle con una cantidad finita de ejecuciones lo que debe usar es FOR, pero si tienes un numero variable tienes dos alternativa: calcular la cantidad de veces y usar FOR o ejecutar DO WHILE.
En este caso deberías usar un DO WHILE para cada columna, es decir 6 DO WHILE... eso es lo que lo lógica manda... pero tu caso es bastante particular... pues se presta a resolverlo usando una técnica un poco complicada de entender pero muy lógica si es que uno la llega a entender...
Me puse a pensar que decías que la cantidad de frutas podía ser variable... eso no es ningún problema, un ciclo DO WHILE lo resuelve sin problema... pero necesitas anidar 6 de estos uno dentro de otro para recorrer cada columna... eso me hizo pensar... ¿y si aumentan las columnas?... tendría que insertar otro ciclo, es decir, la macro ya no tan automática... hasta que se me ocurrió resolver el problema con una Subrutina recursiva... ¿que es eso? Una subrutina que se llama a si misma... un poco loco, ¿no?
Aquí va el planteamiento... ( y funciona para la cantidad de filas y columnas que se te antoje)... La macro calculará la cantidad de columnas, luego los límites de cada columnas, y luego corre el primer FOR en la primera columna, pero dentro de ese FOR, llama a la misma subrutina para ejecutar el FOR en la 2da columna, y este a su vez lo hace en la 3ra... y asi... sucesivamente.
Las subrutinas o funciones recursivas son difíciles de escribir pero suelen ser más cortas que el enfoque tradicional (iterativo)... finalmente, aquí va: tienes que ejecutar "maestro"
Option Base 1
Private tabla As ListObject, nivel%, lim%(), x%, n%, valor$()
Private celda As Range
Sub maestro()
Dim m%, i%
Set celda = Range("A12") ' ADAPTAR A SITUACION REAL
Set tabla = Sheets("Hoja1").ListObjects("Tabla1") ' ADAPTAR A SITUACION REAL
n = tabla.ListColumns.Count
ReDim lim(n), valor(n)
x = 0
For i = 1 To n
m = 1
Do While tabla.HeaderRowRange.Cells(1, i).Offset(m, 0) <> Empty
m = m + 1
Loop
m = m - 1
lim(i) = m
Next i
forREC 1
End Sub
Sub forREC(nivel)
Dim j%, k%
For j = 1 To lim(nivel)
For k = 1 To nivel - 1
celda.Offset(x, k) = valor(k)
Next k
valor(nivel) = tabla.DataBodyRange(j, nivel)
celda.Offset(x, nivel) = valor(nivel)
If nivel = n Then
x = x + 1
End If
DoEvents
If nivel < n Then
forREC (nivel + 1)
End If
Next j
End SubSaludos,
Jaime
PD: Gracias por la pregunta, resultó muy interesante sobre todo para volver a utilizar, después de mucho tiempo, esta simpática técnica.