Confeccionar una subrutina en vba de excel

. 07.03.17 #VBA Encontrar sumandos. Conciliación de valores

Buenas noches, Raúl

He dedicado algún tiempo a tu pregunta porque me ha parecido un desafío más que interesante.

Desde luego verás que la otra solución no te llevaría a ningún lado.

Ten presente que a medida que agregues números para cotejar la rutina demorará más tiempo en ejecutarse. El primer bucle que te mencionaron (y lleva varios) deberá revisar tantos ciclos como la resultante de 2 elevado a la cantidad de números que coloques para sumar. En tu ejemplo, de 13 valores, la rutina deberá armar 8.191 combinaciones y compararlas con tu número a buscar.

En mi equipo le llevó 20 segundos hacerlo, aunque no encontró ninguna combinación que diera exactamente 1.772,74, como planteaste en tu ejemplo. Sí lo hizo con otras sumas. Tal vez no sea esa la cifra a buscar, pero funciona correctamente. En caso de no encontrarla, también te avisa de ello.

Entiendo que no debe haber un límite de valores pero ten en cuenta el tiempo que insumirá procesarlo. De todos modos, aunque tarde, siempre será más veloz que intentar armarlo a mano.

Antes de ejecutar la rutina que comparto, arma tu planilla como en este ejemplo:

Luego, accede al Editor de VBA (Atajo: Alt + F11), allí inserta un módulo (Insertar-Módulo) y pega el siguiente código:

Option Base 1
Public NumBin
Sub BuscaSum()
Dim TablaVal()
'---- Variables modificables ----
'=== RAUL, modifica estos datos de acuerdo a tu proyecto:
    aBuscar = "B5" ' Celda donde se indica el total a buscar
    iniTabla = "B8" ' Celda donde inician los valores a considerar
    PrimCelda = "D8" ' Celda donde empezará a dejar los resultados obtenidos (if any)
'---- fin Variables
'
'---- inicio de rutina:
'  
Range(PrimCelda, ActiveSheet. Range(Left(PrimCelda, 1) & Rows. Count).End(xlUp). Address). ClearContents
Application.ScreenUpdating = False
IniTime = Now
LaFila = 0
cont = 0
aBuscar = Range(aBuscar).Value
    'Loop de coleccion de valores a consderar y direcciones de celda
 'una matriz multidemensional donde el primer elemento es el valor y
 'el segundo es la dirección de la celda donde se encuentra
    With Range(iniTabla)
        Do While Not IsEmpty(.Offset(LaFila))
            ReDim Preserve TablaVal(2, 1 + LaFila)
            ElValor = .Offset(LaFila).Value
            LaDire = .Offset(LaFila).Address(False, False)
            TablaVal(1, 1 + LaFila) = ElValor
            TablaVal(2, 1 + LaFila) = LaDire
            LaFila = LaFila + 1
        Loop
    End With
CantComb = 2 ^ LaFila - 1
For Valo = 1 To CantComb
LaSuma = 0
Argumen = 0
    'NumBin = Application.WorksheetFunction.Dec2Bin(Valo)
    Deci2Bina (Valo)
    NumBin = String(LaFila - Len(NumBin), "0") & NumBin
    For Posi = 1 To LaFila
        LaSuma = TablaVal(1, Posi) * Mid(NumBin, Posi, 1) + LaSuma
        If Val(Mid(NumBin, Posi, 1)) = 1 Then
            If Len(Argumen) > 1 Then
                Argumen = Argumen & Application.International(xlListSeparator) & TablaVal(2, Posi)
            Else
                Argumen = TablaVal(2, Posi)
            End If
        End If
    Next
        If LaSuma = aBuscar Then
            Range(PrimCelda).Offset(cont).FormulaLocal = "=suma(" & Argumen & ")"
            Application.ScreenUpdating = True
            Application.ScreenUpdating = False
            cont = cont + 1
        End If
Next
    FinTime = Now - IniTime
    FinTime = Format(FinTime, "hh:mm:ss")
ElMensaje = IIf(cont = 0, "NO SE ENCONTRO COMBINACION ALGUNA para " & Chr(10) & "el valor " & aBuscar, "Se encontraron: " & cont & " combinaci" & IIf(cont > 1, "ones", "ón") & Chr(10) & "para armar el valor " & aBuscar & Chr(10) & "en un tiempo de " & FinTime & " (hh:mm:ss)") ' & Chr(10) & Chr(10) & "(Ratio: " & RatioC & " registros por segundo)")
TipoMens = IIf(cont = 0, vbCritical, vbInformation)
ElTitulo = IIf(cont = 0, "NO ENCONTRO RESULTADO COINCIDENTE", "TERMINADO!")
Application.ScreenUpdating = True
MsgBox ElMensaje, TipoMens, ElTitulo
End Sub
Private Sub Deci2Bina(ByVal Valo As Long)
    NumBin = ""
    Numero = Valo 
        Do
          Residuo = Numero Mod 2 
            NumBin = NumBin & Trim(Str(Residuo)) 
            Numero = Int(Numero / 2) 
        Loop Until Numero < 2 
        If (Numero = 1) Then 
            NumBin = "1" & StrReverse(NumBin) 
        Else
            NumBin = StrReverse(NumBin) 
        End If
End Sub

Nota que, al principio del código, hay unas variables que corresponden a las celdas marcadas en verde en la imagen. Al ser variables, puedes modificarlas para adaptar el modelo a tu archivo.

Desde luego, los valores a considerar deben ser únicamente del cliente en cuestión.

El resultado será una lista de fórmulas de suma que logran el total buscado. Editando la fórmula verás qué celdas consideró en cada caso.

Bien, Raúl, espero que te sirva y que sea lo que buscabas.

Pd: con esto postergo por unos meses al Alzheimer... Je!

.

.

Buenas, Raúl

En virtud de la expectativa que me generó tu pregunta, me interesa saber si pudiste probar la solución y si te resolvió el problema.

Sólo eso.

Muy buen fin de semana.

Fer

.

.

Hola, Raúl

¿Será qué no tuviste oportunidad de probarla o no llegaste a ver mi respuesta?

Espero -curioso- tus comentarios.

Abrazo

Fer

.