permutaciones ingredientes en un producto :O

[nightz]

Hola, espero alguien me pueda ayudar con esto que ya no se que hacer,

Necesito lograr lo siguiente:

deseo que se hagan permutaciones de diferentes ingredientes de un producto, pero que tengan reglas para evitar combinaciones que no se usaran nunca, ejemplo:

columnas

A B C

Naranja Limón Cereal

Este es el archivo que utilizo, chequenlo porfavor:

https://www.dropbox.com/sh/8jnoujhurswcfn3/97VoOEtoxw/Combinaciones productos.xlsm

Deseo tener un macro que me permita poner excepciones en sus combinaciones y que no se repitan los ingredientes, ejemplo:

Sandia, Jicama, Jicama, Limón, Sal,

Jicama, Jicama, Sandia, Limón, Sal,

Gracias, muchas gracias.

[Antoni]

Bienvenido al foro:

El tema puede parecer interesante, pero, sin archivo de muestra, y un ejemplo claro de lo que quieres lo tienes muy complicado para que haya respuestas.

Revisa las normas del foro, por favor.

Saludos.

[michico]

Esto de las permutaciones me chifla, lo que dice Macro Antonio es cierto.

Manda archivo plis, estoy leyendo el código y me duele la vista al verlo sin escalonar.

[nightz]

Perdon, como soy nuevo en el foro ya la regue jeje, pero ya actualice mi publicación y les dejo mi archivo, es un link de dropbox pueden descargarlo sin problemas, muhas gracias por sus respuestas, espero logremos encontrar la solución

[michico]

Perdon, como soy nuevo en el foro ya la regue jeje, pero ya actualice mi publicación y les dejo mi archivo, es un link de dropbox pueden descargarlo sin problemas, muhas gracias por sus respuestas, espero logremos encontrar la solución

mmm... el archivo consigo abrirlo en excel 2003 pero quizá hay alguna cosa que no consigo ver.

A ver si lo he entendido quieres tener combinaciones pero que los ingredientes no se repitan.

Entonces, hay dos opciones o directamente borrar los repetidos antes de buscar combinaciones.

O dentro de las combinaciones. Hacer un filtro antes de apuntar la next combinación.

Sub Combinar()
Application.Calculation = xlCalculationManual
'Range("G2:G1009999").Select
'Selection.ClearContents
Range("G1").Select
Dim i As Integer, j As Integer, k As Integer, l As Integer, m As Integer, UltFilA As Integer, UltFilB As Integer, UltFilC As Integer, UltFilD As Integer, UltFilE As Integer, Aux As Integer
Aux = 2
UltFilA = Range("A65536").End(xlUp).Row
UltFilB = Range("B65536").End(xlUp).Row
UltFilC = Range("C65536").End(xlUp).Row
UltFilD = Range("D65536").End(xlUp).Row
UltFilE = Range("E65536").End(xlUp).Row
For i = 1 To UltFilA
  For j = 1 To UltFilB
    For k = 1 To UltFilC
      For l = 1 To UltFilD
        For m = 1 To UltFilE

'Aquí metes el filtro.
'Como de cada columna cojes solo un valor.
'Haces algo así.

If Range("A" & i) <> Range("B" & j) & Range("A" & i) <> Range("C" & K) & Range("A" & i) <> ... todas las combos posibles ... Then

    'Aquí pondrá el valor solo si son distintos los valores. Es un coñazo manejar los condicionales de dos en dos pero no se me ocurre otra forma. Si alguien la sabe que lo diga, yo tm estoy interesado.

    Range("G" & Aux) = Range("A" & i) & Range("B" & j) & Range("C" & k) & Range("D" & l) & Range("E" & m)
    Aux = Aux + 1

End If
        Next m
      Next l
    Next k
  Next j
Next i
Application.Calculation = xlCalculationAutomatic
End Sub[/PHP]

[nightz]

Graxias por la respuesta @michico, estoy probando tu opción, vere que tal nos funciona, y ahora solo faltaria saber como colocarle condiciones para evitar combinaciones con productos que generalmente no se combinan, ejemplo:

Una combinación normal y aceptada es:

Melón, Sandía, Yogurth de fresa, Granola

Preo una combinación nada apetitosa y que no me interesa es:

Melón, Límon, Chile seco, Yogurth de fresa

Ciertamente esta perro esto, pero estoy seguro que lo podemos lograr

GRACIAS!!

[nightz]

A, y otro dato, lo hice con el excel 2010, lo comento para que conozcan la versión que uso, lo voy a guardar con compatibilidad y lo volvere a subir, pero creo que si se puede usar y visualizar igual en el 2003, gracias.

[nightz]

Mira hice esto, no se si sea la idea que me planteas @michico, pero al utilizar la macro no pasa nada diferente, las combinaciones se generan iguales.

Sub h()
Application.Calculation = xlCalculationManual
Range("G2:G1009999").Select
Selection.ClearContents
Range("G1").Select
Dim i As Integer, j As Integer, k As Integer, l As Integer, m As Integer, UltFilA As Integer, UltFilB As Integer, UltFilC As Integer, UltFilD As Integer, UltFilE As Integer, Aux As Integer
Aux = 2
UltFilA = Range("A65536").End(xlUp).Row
UltFilB = Range("B65536").End(xlUp).Row
UltFilC = Range("C65536").End(xlUp).Row
UltFilD = Range("D65536").End(xlUp).Row
UltFilE = Range("E65536").End(xlUp).Row
For i = 1 To UltFilA
  For j = 1 To UltFilB
    For k = 1 To UltFilC
      For l = 1 To UltFilD
        For m = 1 To UltFilE
If Range("A" & i) <> Range("B" & j) & Range("A" & i) <> Range("C" & k) & Range("A" & i) <> Range("D" & l) & Range("A" & i) <> Range("E" & m) Then
 If Range("A" & j) <> Range("B" & j) & Range("A" & j) <> Range("C" & k) & Range("A" & j) <> Range("D" & l) & Range("A" & j) <> Range("E" & m) Then
  If Range("A" & k) <> Range("B" & j) & Range("A" & k) <> Range("C" & k) & Range("A" & k) <> Range("D" & l) & Range("A" & k) <> Range("E" & m) Then
   If Range("A" & l) <> Range("B" & j) & Range("A" & l) <> Range("C" & k) & Range("A" & l) <> Range("D" & l) & Range("A" & l) <> Range("E" & m) Then
    If Range("A" & m) <> Range("B" & j) & Range("A" & m) <> Range("C" & k) & Range("A" & m) <> Range("D" & l) & Range("A" & m) <> Range("E" & m) Then
     If Range("B" & i) <> Range("A" & j) & Range("B" & i) <> Range("C" & k) & Range("B" & i) <> Range("D" & l) & Range("B" & i) <> Range("E" & m) Then
      If Range("B" & j) <> Range("A" & j) & Range("B" & j) <> Range("C" & k) & Range("B" & j) <> Range("D" & l) & Range("B" & j) <> Range("E" & m) Then
       If Range("B" & k) <> Range("A" & j) & Range("B" & k) <> Range("C" & k) & Range("B" & k) <> Range("D" & l) & Range("B" & k) <> Range("E" & m) Then
        If Range("B" & l) <> Range("A" & j) & Range("B" & l) <> Range("C" & k) & Range("B" & l) <> Range("D" & l) & Range("B" & l) <> Range("E" & m) Then
         If Range("B" & m) <> Range("A" & j) & Range("B" & m) <> Range("C" & k) & Range("B" & m) <> Range("D" & l) & Range("B" & m) <> Range("E" & m) Then
          If Range("C" & i) <> Range("A" & j) & Range("C" & i) <> Range("B" & k) & Range("C" & i) <> Range("D" & l) & Range("C" & i) <> Range("E" & m) Then
           If Range("C" & j) <> Range("A" & j) & Range("C" & j) <> Range("B" & k) & Range("C" & j) <> Range("D" & l) & Range("C" & j) <> Range("E" & m) Then
            If Range("C" & k) <> Range("A" & j) & Range("C" & k) <> Range("B" & k) & Range("C" & k) <> Range("D" & l) & Range("C" & k) <> Range("E" & m) Then
             If Range("C" & l) <> Range("A" & j) & Range("C" & l) <> Range("B" & k) & Range("C" & l) <> Range("D" & l) & Range("C" & l) <> Range("E" & m) Then
              If Range("C" & m) <> Range("A" & j) & Range("C" & m) <> Range("B" & k) & Range("C" & m) <> Range("D" & l) & Range("C" & m) <> Range("E" & m) Then
               If Range("D" & i) <> Range("A" & j) & Range("D" & i) <> Range("B" & k) & Range("D" & i) <> Range("C" & l) & Range("D" & i) <> Range("E" & m) Then
                If Range("D" & j) <> Range("A" & j) & Range("D" & j) <> Range("B" & k) & Range("D" & j) <> Range("C" & l) & Range("D" & j) <> Range("E" & m) Then
                 If Range("D" & k) <> Range("A" & j) & Range("D" & k) <> Range("B" & k) & Range("D" & k) <> Range("C" & l) & Range("D" & k) <> Range("E" & m) Then
                  If Range("D" & l) <> Range("A" & j) & Range("D" & l) <> Range("B" & k) & Range("D" & l) <> Range("C" & l) & Range("D" & l) <> Range("E" & m) Then
                   If Range("D" & m) <> Range("A" & j) & Range("D" & m) <> Range("B" & k) & Range("D" & m) <> Range("C" & l) & Range("D" & m) <> Range("E" & m) Then
                    If Range("E" & i) <> Range("A" & j) & Range("E" & i) <> Range("B" & k) & Range("E" & i) <> Range("C" & l) & Range("E" & i) <> Range("D" & m) Then
                     If Range("E" & j) <> Range("A" & j) & Range("E" & j) <> Range("B" & k) & Range("E" & j) <> Range("C" & l) & Range("E" & j) <> Range("D" & m) Then
                      If Range("E" & k) <> Range("A" & j) & Range("E" & k) <> Range("B" & k) & Range("E" & k) <> Range("C" & l) & Range("E" & k) <> Range("D" & m) Then
                       If Range("E" & l) <> Range("A" & j) & Range("E" & l) <> Range("B" & k) & Range("E" & l) <> Range("C" & l) & Range("E" & l) <> Range("D" & m) Then
                        If Range("E" & m) <> Range("A" & j) & Range("E" & m) <> Range("B" & k) & Range("E" & m) <> Range("C" & l) & Range("E" & m) <> Range("D" & m) Then
   Range("G" & Aux) = Range("A" & i) & Range("B" & j) & Range("C" & k) & Range("D" & l) & Range("E" & m)
   Aux = Aux + 1

End If
        Next m
      Next l
    Next k
  Next j
Next i

[/PHP]

[michico]

Solo has de hacer una combo por columna.

Dame un ratito y modifico este post con el If que habrías de poner.

Ok, ya ta...

¿Alguien sabe porque no funciona el condicional?

Sub Combinar()
Application.Calculation = xlCalculationManual
Range("G2:G60000").Select
Selection.ClearContents
Range("G1").Select
Dim a As String, b As String, c As String, d As String, e As String
Dim i As Integer, j As Integer, k As Integer, l As Integer, m As Integer, UltFilA As Integer, UltFilB As Integer, UltFilC As Integer, UltFilD As Integer, UltFilE As Integer, Aux As Integer
Aux = 2
UltFilA = Range("A65536").End(xlUp).Row
UltFilB = Range("B65536").End(xlUp).Row
UltFilC = Range("C65536").End(xlUp).Row
UltFilD = Range("D65536").End(xlUp).Row
UltFilE = Range("E65536").End(xlUp).Row
For i = 1 To UltFilA
  For j = 1 To UltFilB
    For k = 1 To UltFilC
      For l = 1 To UltFilD
        For m = 1 To UltFilE

            'Aquí pongo las variables para no escribir tanto.
            a = Range("A" & i)
            b = Range("B" & j)
            c = Range("C" & k)
            d = Range("D" & l)
            e = Range("E" & m)

           'Este es el condicional, pero no funciona... Los strings son puñeteros. No entiendo bien el problema.
            If ((a <>  & (a <> c) & (a <> d) & (a <> e) & _
            (b <> c) & (b <> d) & (b <> e) & _
            (c <> d) & (c <> e)) Then

            'He probado esta alternativa, pero tampoco funciona...
            'If ((StrComp(a, b, 1) = StrComp(a, c, 1) = StrComp(a, d, 1) = StrComp(a, e, 1) = _
            'StrComp(b, c, 1) = StrComp(b, d, 1) = StrComp(b, e, 1) & _
            'StrComp(c, d, 1) = StrComp(c, e, 1)) <> 0) Then
                Range("G" & Aux) = Range("A" & i) & Range("B" & j) & Range("C" & k) & Range("D" & l) & Range("E" & m)
                Aux = Aux + 1
            End If
        Next m
      Next l
    Next k
  Next j
Next i
Application.Calculation = xlCalculationAutomatic
End Sub[/PHP]

[Lázaro]

Saludos nightz y michico

Aquí les dejo una Macro sacada de este Foro que quizás les pudiera ayudar a resolver el problema, en lo personal de Macros no sé nada, igual ni se acerca con lo que ustedes pretenden hacer o quizás modificándola un poco puedan solucionar el Tema, está pensada para Combinaciones Numéricas, pero entre las tantas pruebas que le realizado para tratar de adaptarla a mis necesidades también sirve para Texto.

Saludos

Lázaro

Sub GneraCombinacionesII()

  Dim V(60), x, y, z

  Application.DisplayStatusBar = True
  Application.StatusBar = ""

  For x = 1 To 60: V(x) = "": Next x

  Range("B18:t65019").ClearContents

  'Guardamos los números en un array
  z = 1
  For y = 10 To 20 Step 2
     For x = 5 To 14
        V(z) = ActiveSheet.Cells(x, y)
        z = z + 1
     Next x
  Next y

  'Buscamos números repetidos
  For x = 1 To 60
     For y = x + 1 To 60
        If V(x) > 0 Then
           If V(x) = V(y) Then
              Cadena = Cadena & " " & V(y)
              V(y) = 0
           End If
        End If
     Next
  Next

  'Generamos combinaciones
  ActiveSheet.Range("b20:B743").ClearContents
  Application.ScreenUpdating = False

  x = 18
  For a = 1 To 10:   For b = 11 To 20:   For c = 21 To 30
     For d = 31 To 40: For e = 41 To 50: For f = 51 To 60
        If reales > 393000 Then
           MsgBox "Solo se han generado las primeras 393.000 combinaciones.", vbInformation
           GoTo Report
        End If
        If V(a) <> "" And V( <> "" And V(c) <> "" And V(d) <> "" And V(e) <> "" And V(f) <> "" Then
           If Total Mod 1000 = 0 Then Application.StatusBar = "Combinación: " & Total
           Total = Total + 1
           If V(a) > 0 And V( > 0 And V(c) > 0 And V(d) > 0 And V(e) > 0 And V(f) > 0 Then
              reales = reales + 1
              y = reales Mod 1
              If y = 0 Then y = 1
              ActiveSheet.Cells(x, y * 2) = V(a) & " " & V( & " " & V(c) & " " & V(d) & " " & V(e) & " " & V(f)
              If y = 1 Then x = x + 1
           End If
        End If
     Next: Next: Next
  Next: Next: Next

  'Visualizamos report de proceso
  Report:
  ActiveSheet.Range("B4").Activate
  If Cadena <> "" Then
     MsgBox "Números duplicados: " & Cadena & Chr(10) & _
            "Combinaciones teóricas:    " & Total & Chr(10) & _
            "Combinaciones generadas:  " & reales & Chr(10) & _
            "Combinaciones eliminadas: " & Total - reales & Chr(10), vbExclamation
  Else
     MsgBox "Combinaciones generadas: " & reales & Chr(10), vbInformation
  End If
  Application.DisplayStatusBar = False

  End Sub
[/PHP]

[michico]

Ya está. Creo que con esto solucionas el tema.

'Application.Calculation = xlCalculationManual
Range("G2:G60000").Select
Selection.ClearContents
Range("G1").Select
Dim i As Integer, j As Integer, k As Integer, l As Integer, m As Integer, UltFilA As Integer, UltFilB As Integer, UltFilC As Integer, UltFilD As Integer, UltFilE As Integer, Aux As Integer
Aux = 2
UltFilA = Range("A65536").End(xlUp).Row
UltFilB = Range("B65536").End(xlUp).Row
UltFilC = Range("C65536").End(xlUp).Row
UltFilD = Range("D65536").End(xlUp).Row
UltFilE = Range("E65536").End(xlUp).Row
For i = 1 To UltFilA
  For j = 1 To UltFilB
    For k = 1 To UltFilC
      For l = 1 To UltFilD
        For m = 1 To UltFilE

            'inicializacion variables.
            a = Range("A" & i)
            b = Range("B" & j)
            c = Range("C" & k)
            d = Range("D" & l)
            e = Range("E" & m)

            'Filtro si son diferentes los valores cogidos de cada columna escribe sino no.
            If (a <>  And (a <> c) And (a <> d) And (a <> e) And _
            (b <> c) And (b <> d) And (b <> e) And _
            (c <> d) And (c <> e) And _
            (d <> e) Then
                Range("G" & Aux) = Range("A" & i) & Range("B" & j) & Range("C" & k) & Range("D" & l) & Range("E" & m)
                Aux = Aux + 1
            End If
        Next m
      Next l
    Next k
  Next j
Next i
'Application.Calculation = xlCalculationAutomatic[/PHP]

Cuidado no he declarado a,b,c,d,e, así que si usas Option Explicit posiblemente te diga warning.

Para declarar variables ya sabes Dim <nombre> As <tipo>

[Visor]

Claro que hasta este momento este tema quiza ya haya perdido vigencia pero por si lo  leen creo que esto es un calculo de arreglos factoriales 2 x 2 o de 2 x 3 etc, esto crearia una tabla que permite hacer los ensayos que convengan o todos y cada uno genera sus propios resultados diferentes