Localizar Varias Sumas

Written by Hector Miguel. Posted in Solver

Excel Combinaciones Solver

Por ejemplo, si trabajamos con facturas, alguna vez hemos necesitado saber cuáles de esas facturas suman una determinada cantidad. En el artículo de hoy os mostraremos como podéis localizar esas sumas y exactamente que celdas suman esa determinada cantidad, utilizando Código Solver y Combinaciones.

Desarrollo

Pasos a realizar antes de Ejecutar el Código:

Agregar Referencia al complemento Solver.xla [Versiones anteriores a Office 2007 ] - Solver.xlam [Versión Office 2007 ]

1 Abrimos el Editor de Visual Basic Excel con la combinación de teclas [ Alt + F11 ]

En el editor de Visual Basic, nos vamos a menú Herramientas y click en Referencias.

2 En el cuadro de diálogo que nos aparece, click en el botón Examinar.

3 En el cuadro de diálogo Agregar Referencias, nos dirigimos hacia la siguiente ruta:

Para la Versión office 2007

Archivos de programa\Microsoft Office\Office 12\Libray\Solver\SOLVER.XLAM

Para Versiones anteriores de Office

Archivos de programa\Microsoft Office\Office XX\Libray\Solver\SOLVER.XLA (donde XX pertenece a la Versión de office instalada)

4 Observamos en el Proyecto - VBAProyect que se ha cargado el complemento [Solver.xla/m]

Dentro del Módulo 1 observaremos el procedimiento:

Sub Localizar_Sumas(): Dim Intento As Long, Celda As Range, Sig As Integer, Opcion As String
  Range([Opciones].Offset(1), [Opciones].Offset(1).End(xlDown)).ClearContents
  [Sumandos].ClearContents: Application.ScreenUpdating = False
  For Intento = 1 To [Posibles]
    SolverReset
    SolverOk SetCell:="" & [Prueba].Address & "", _
                    MaxMinVal:=3, _
                    ValueOf:="" & Intento & "", _
                    ByChange:="" & [Sumandos].Address & ""
    SolverAdd CellRef:="" & [Sumandos].Address & "", _
                      Relation:=5, _
                      FormulaText:="Binario"
    SolverOptions Precision:=0.000001, _
                            Convergence:=0.001
    SolverOk SetCell:="" & [Prueba].Address & "", _
                    MaxMinVal:=3, _
                    ValueOf:="" & Intento & "", _
                    ByChange:="" & [Sumandos].Address & ""
    SolverSolve UserFinish:=True
    If [Resultado] = [Objetivo] Then
      For Each Celda In [Sumandos]
        If Celda > 0 Then
          If Opcion <> "" Then Opcion = Opcion & "+"
          Opcion = Opcion & LCase(Celda.Offset(, -1).Address(False, False))
        End If: Next: Sig = Sig + 1: [Opciones].Offset(Sig) = Sig & ") " & Opcion: Opcion = ""
    End If: Next: [Opciones].EntireColumn.AutoFit: End Sub

Si la Versión instalada de Office es en Inglés, buscaremos en el procedimiento [ Sub Localizar_Sumas() ]:

Binario y se reemplazará por Binary

Si la Versión de office es XP (2002), (2003) ó (2007), buscaremos y reemplazaremos lo siguiente en el código

SolverOk y lo reemplazaremos por SolvOk

Realizaremos el mismo proceso para:

SolverAdd por SolvAdd

5 Ahora sí podemos ejecutar el Código, para ello:

Cerramos Visual Basic y nos vamos a la interfaz de Excel, y presionamos la combinación de teclas [ALT+F8 ], en el cuadro de diálogo Macro, seleccionamos el procedimiento Localizar_Sumas y click enEjecutar, una vez terminado de realizar los cálculos observaremos lo siguiente:

• Columna ID

Identificadores por ejemplo de números de Factura.

• Columna Valores

Reservada toda la columna exclusivamente solo para los Valores/importes los cuales van a ser sumados, SIN exceder el límite de Solver de 200 Celdas cambiantes [o… sumables].

TIP: No mayores a la cantidad Buscada 

• Columna Combinar

Si se agrega/elimina números sumables en la columna Valores …[de]crece las fórmulas de esta columna. SIN EXCEDER el límite del Solver de 200 celdas cambiantes [o… sumables].

• Celda Posibles

Cuenta las posibles combinaciones, considerando que las posibles combinaciones son: 2^n_sumables-1

Si se trata de muchos sumables, el proceso se volverá bastante lento.

• Celda Prueba

Contador que monitorea las posibilidades.

• Celda Objetivo

El valor final sumatoria que se busca.

• Celda Resultado

Un paso temporal, compara resultados.

• Celda Opciones

Aquí se escriben las combinaciones posibles cuya suma da [ 5 ] de los valores de la columna [Valores ].

6 Si se produce un error del tipo:Memoria agotada o error inesperado

En el editor de Visual Basic de Excel, presionamos la combinación de teclas [ Ctrl+G ] para abrir la ventana inmediato y ahí escribimos la siguiente instrucción y pulsaremos la tecla Enter:

Application.Run ("Solver.xlam!Auto_Open") ó bien Application.Run ("Solver.xla!Auto_Open")

6Nombres dinámicos y Nombres estáticos utilizados:

Código utilizado para los botones de Instrucciones - Comentarios

Private Sub Instrucciones_Click()
  With Me.Shapes("Instrucciones")
    .Visible = (Instrucciones = -1)
  End With: SendKeys "{Esc}"
End Sub


Private Sub Comentarios_Click(): Dim Mostrar
  If Comentarios = -1 Then Mostrar = xlCommentAndIndicator _
  Else Mostrar = xlCommentIndicatorOnly
  Application.DisplayCommentIndicator = Mostrar: SendKeys "{Esc}"
End Sub

Función Personalizada

La siguiente Función Personalizada obtiene la localización de una Suma solicitada en el rango donde se necesite buscar.

Los argumentos opcionales son:

Direccion => obtener la dirección de la/s celda/s o su/s valores

Ultima => obtener los valores que dan la suma de abajo-arriba o de arriba-abajo

=BuscarSumandos(A1,B18:B45,1,1)

OJO: si existen dos (o más) "posibilidades", SOLO DEVUELVE UNA '

' (basado en el codigo original de Jimmy L. Day: -> http://tinyurl.com/3qglnn) '
Private Objetivo As Double, Optimo As Double, Celdas As Integer, n As Integer, _
Prueba() As Integer, Confirma() As Integer, Compara As String, Valores


Function BuscarSumandos(Buscar As Double, Buscar_donde As Range, _
Optional Direccion As Boolean = False, _
Optional Ultima As Boolean = False) As String
Dim Tmp As String
Optimo = 0
Objetivo = Buscar
Compara = IIf(Ultima, "<", "<=")
With Buscar_donde.Columns(1)
Celdas = .Rows.Count
Valores = Application.Transpose(.Value)
ReDim Prueba(Celdas)
ReDim Confirma(Celdas)
Evalua 0, 1
For n = 1 To Celdas
If Confirma(n) Then Tmp = Tmp & "+" & IIf(Direccion, .Cells(n).Address(0, 0), .Cells(n))
Next
End With
If Tmp = "" Then
BuscarSumandos = "Sumandos NO Localizados !!!"
Exit Function
End If
BuscarSumandos = IIf(Evaluate(Tmp) <> Objetivo, "Aproximado: ", "") & "=" & Mid(Tmp, 2)
End Function


Private Function Evalua(ByVal Suma As Double, ByVal Pos As Integer)
If Pos <= Celdas Then
Prueba(Pos) = 0
Evalua Suma, Pos + 1
Prueba(Pos) = 1
Evalua Suma + Valores(Pos), Pos + 1
Else
Select Case Compara
Case "<="
If (Abs(Suma - Objetivo) <= Abs(Objetivo - Optimo)) Then
Optimo = Suma
For n = 1 To Celdas
Confirma(n) = Prueba(n)
Next
End If
Case "<"
If (Abs(Suma - Objetivo) < Abs(Objetivo - Optimo)) Then
Optimo = Suma
For n = 1 To Celdas
Confirma(n) = Prueba(n)
Next
End If
End Select
End If
End Function

Print