Sumar y restar dentro de un listado hasta conformar un valor consultado, luego copiar y pegar en otra hoja

H o l a:

No entendí bien.

En la hoja2, celda A3 tienes "EUR", en B3 el valor 2.563

En la columna I se busca "EUR"

¿En cuál columna de la hoja1 se va a buscar el valor 2.563? ¿En la columna J?

Y por qué dices:

"busco todos los montos que su suma den 2.563"

¿La macro tiene que realizar alguna suma? Esa es la parte que no entiendo. 

Gracias por responder, si en la hoja 2 en la columna A esta el tipo de moneda y en la letra b el monto a buscar, en la hoja 1 en la columna i esta el tipo de moneda y en columna j Los montos a sumar

lo primero que hay que hacer es identificar el tipo de moneda, luego buscar en la columna j los montos que sumen 2563, copiar las filas completas y llevarlas a otra hoja, asi por cada monto que haya en la columna b de la hoja2.

la idea es saber que filas de la hoja1 corresponden al monto de hoja2

ejemplo

En la hoja1 tengo en la columna i y j tengo

Eur  1.000

eur      563

eur  1.000

usd   2000

En la hoja 2 en la columna a y b tengo

eur 2563

eur 1546

usd 2500

Lo que hay que hacer es identificar el tipo de moneda y despues encontar los valores que sumen en este caso 2563

En la hoja1 tengo 3 filas que suman los 2563

Eur 1.000

eur 563

eur 1.000

Corto las filas y las pego en hoja 3

despues sigo con el siguiente valor de la

hoja 2 

eur 1546 y vuelvo a buscar en hoja 1 los valores que sumen 1546 y que el tipo de cambio sea eur y así sucesivamente 

Gracia por tu ayuda espero me entienda 

Pero eso es muy relativo

Si en la hoja 2 tienes esto:

HOJA2

EUR    5

'

Y en la hoja1 tienes:

HOJA1

EUR 1

EUR 2

EUR 3

EUR 4

EUR 5

'

¿Cuáles registros son los que se tienen que copiar?

PRIMER PUNTO:

Ya que 1 y 4 suman 5

También 2 y 3 suman 5

También 5 suman 5

SEGUNDO PUNTO:

Además el orden de los importes también influye.

Si sumo 1 + 2 = 3

Después sumo 3 + 3 = 6, entonces la suma ya se pasó de 5, eso significa que la suma de los 3 primeros importes excedió el valor buscado: 5. Ahí se detiene la macro.

No tengo una macro que busque combinaciones, es decir, que

Sume registro 1 + registro 2 + registro 3, si ya se pasó,

Ahora que empiece con el registro 2 + registro 3 + registro 4, si ya se pasó,

Ahora que empiece con el registro 3 + registro 4, etc.

O que empiece con el registro 1 + el registro 3

O el registro 1 + el registro 4, etc.

El ejemplo que te puse es con una cifra pequeña, pero si tienes una cifra más grande como 2563 las combinaciones son bastantes.

Tienes más detalle que puedas proporcionarme para resolver el PRIMER PUNTO Y EL SEGUNDO PUNTO.

Si es que es complicado, te explico más o menos para ver si Se puede realizar, tengo un pago de 1.000.000 de pesos pero me las pagan en cuotas y no tengo referencia que aniden el pago, lo mejor que puede ser para realiZar la macro es : si encuentra el valor entero en este caso 2563 que copie la línea y la lleve a la hoja 3, si no encuentra el monto completo, que lleve la primera suma encontrada a la hoja 3, así no habrán tantas combinaciones ya que la primera que coincida sera la correcta, si no existe coincidencia que refleje en hoja 4 el monto que no encontró.

Hola Dante, buenos días mi consulta es ¿se puede realizar esta macro? se entiende lo que se requiere en mi explicación?.

muchas gracias por tu ayuda 

H o l a:

Sí, entiendo lo que necesitas.

Envíame tu archivo con algunos ejemplos reales. En la hoja 1 me pones varios ejemplos reales. En la hoja 2 me pones los importes que se van a buscar. En la hoja 3 me pones el resultado que esperas; en la hoja 3 vas a poner el resultado, considerando que solamente se realizarán 2 búsquedas, la primera por el monto total y la segunda sumando 2 números únicamente.

Procura poner la información de las 3 hojas en las filas y en las columnas originales, ya que la macro la prepararé para que funcione con esta información; te lo comento por si después decides cambiar de lugar la información, la macro no funcionará y tendremos que ajustar la macro.

Mi correo [email protected]

En el asunto del correo escribe tu nombre de usuario “mauricio1465” y el título de esta pregunta.

Dante, el correo ya fue enviado ojala me puedas ayudar con esta macro

Te anexo la macro para encontrar 2 clases de valores.

1. Cuando el importe es exacto

2. Cuando en la primera suma de valores encuentra el importe exacto.

Sub BuscarValores()
'Por.Dante Amor
    Dim filas As New Collection
    Set h1 = Sheets("Base")
    Set h2 = Sheets("Buscador")
    Set h3 = Sheets("Resultado")
    Set h4 = Sheets("Registros no encontrados")
    H3. Cells. Clear
    H4. Cells. Clear
    H2. Columns("C"). Clear
    '
    H2. Rows(1). Copy h3. Rows(1)
    H2. Rows(2). Copy h4. Rows(2)
    '
    j = 2
    For i = 2 To h2.Range("B" & Rows.Count).End(xlUp).Row
        'busca importe directo
        existe = False
        Set r = h1.Columns("J")
        Set b = r.Find(h2.Cells(i, "B"), lookat:=xlWhole)
        If Not b Is Nothing Then
            celda = b.Address
            Do
                'detalle
                If h1.Cells(b.Row, "I") = h2.Cells(i, "A") Then
                    existe = True
                    fila = b.Row
                    Exit Do
                End If
                Set b = r.FindNext(b)
            Loop While Not b Is Nothing And b.Address <> celda
        End If
        '
        If existe Then
            h3.Cells(j, "A") = h2.Cells(i, "A")
            h3.Cells(j, "B") = h2.Cells(i, "B")
            j = j + 1
            h1.Rows(fila).Copy h3.Rows(j)
            j = j + 2
            h1.Rows(fila).Delete
            h2.Cells(i, "C") = "Si"
        Else
            'busca importe con sumas
            wsuma = 0
            Set filas = Nothing
            For k = 2 To h1.Range("J" & Rows.Count).End(xlUp).Row
                If h1.Cells(k, "I") = h2.Cells(i, "A") Then
                    filas.Add k
                    wsuma = wsuma + h1.Cells(k, "J")
                    If wsuma = h2.Cells(i, "B") Then
                        h3.Cells(j, "A") = h2.Cells(i, "A")
                        h3.Cells(j, "B") = h2.Cells(i, "B")
                        j = j + 1
                        For f = filas.Count To 1 Step -1
                            n = filas(f)
                            h1.Rows(n).Copy h3.Rows(j)
                            j = j + 1
                            h1.Rows(n).Delete
                        Next
                        j = j + 1
                        h2.Cells(i, "C") = "Si"
                        Exit For
                    'ElseIf wsuma > h2.Cells(i, "B") Then
                    '    Exit For
                    'Else
                        'h2.Cells(j, "Z") = "X"
                    End If
                End If
            Next
        End If
    Next
    MsgBox "Fin"
End Sub

' : )
'S aludos. Dante Amor. Recuerda valorar la respuesta. G racias
' : )

¡Gracias!  Dante La voy a probar y te comento

Buenos días, Dante revise el archivo, en algunos casos si suma los monto pero en otros encontrándose la suma, no hace nada, me puedes ayudar con eso, por favor, te envió el archivo con las observaciones para ver si lo puedes revisar por favor

H o l a:

De hecho la macro hace más que eso, la macro sumar el primer valor, el segundo, el tercero, el cuarto, y así, hasta que la suma coincide con el valor buscado.

Lo que tu quieres es que la macro sume el primero, el segundo, el quinto, el séptimo y si no coincide que ahora sume el primero, el segundo, el sexto y el séptimo y si no coincide que haga otra suma.

Como te comenté no tengo una macro para realizar todas las combinaciones posibles.

Habíamos quedado que la macro te iba a buscar el primer valor y la primera suma.

Sal u dos 

Si entiendo dante, pero te explico:

Pero la macro que me enviaste hace lo que necesito pero no para todos los montos, sabiendo que si existe una suma en la hoja base de datos que coloque con color para identificar que coincide con el monto de una celda de la hoja buscador. te envié un correo con las observaciones.

Lo que realmente necesitaba era que buscara de cualquier forma "ordenado o aleatoria" en la hoja Base, la suma de un monto X colocado en la columna B de la  hoja buscador y luego de identificada la suma cortara la linea completa y pegara en otra hoja, después que baje a la siguiente celda siguiente de la columna B y realizara la misma operación. 

Cuando me explicaste que habían varias combinaciones, lo que yo entendí, es que para sumar un numero habías muchas posibilidades, y lo que yo te dije que la primera suma que encuentre entre todas esas combinaciones sera la correcta, y después que siga con el monto de la celda siguiente.

Dante si no se puede realizar, de verdad muchas gracias por tu tiempo y ayuda.

Y lo ultimo porque no se puede ejecutar 2 veces la macro

Te comento, no tengo un algoritmo para realizar todas las combinaciones.

Te pongo un ejemplo para explicar las combinaciones; en el siguiente ejemplo voy a exponer las diferentes combinaciones que se formarían para 4 números:

1. 1
2. 1+2
3. 1+2+3
4. 1+2+3+4
5. 1+3
6. 1+3+4
7. 1+4
8. 2
9. 2+3
10. 2+3+4
11. 2+4
12. 3
13. 3+4
14. 4

Si te fijas, la macro para 4 números tendría que hacer 14 sumas.

Lo que yo te envié son las 4 primeras sumas; y además la búsqueda del valor individual.

Las otras combinaciones no las verifica la macro.

Tendrás que buscar los algoritmos para realizar todas las combinaciones.

Gracias Dante, entiendo perfectamente, pero apelando a tu buena disposición, tengo esta macro que encontré en Internet, que hace lo que necesito, pero sin tanto detalle como te lo pedí a ti, el único problema que tengo es que las suma de las columnas deben ser iguales, y si coloco numero con decimales, o muchos numeros me arroja un error de desbordamiento

tu me puedes ayudar a adaptar esta macro y fusionarlas con la tuya, si no se puede no importa, es solo que necesito esta macro con urgencia, ojala y entiendo si no puedes.

Option Explicit
Dim Rng As Range
Dim Obj#, Msg$, Q%

Sub ComponeSuma()

Dim C As Range, Ini As Double

If Not IsNumeric([c3]) Or IsEmpty([c3]) Then Exit Sub

If WorksheetFunction.CountBlank(Range([c3], [c65536].End(xlUp))) > 0 Then
MsgBox "El rango de datos contiene" & vbLf & "celdas en blanco."
Exit Sub
End If

With Range([e2], [e1000].End(xlUp))
If WorksheetFunction.Count(.Cells) = 0 Then
MsgBox "Debe establecer -al menos- un objetivo."
Exit Sub
End If
Application.ScreenUpdating = False
.Sort [e2], xlAscending, Header:=xlYes
End With

Ini = Timer
Range("d:d,f:f").ClearContents
Hoja2.UsedRange.EntireColumn.Delete Shift:=xlToLeft

For Each C In Range([e3], [e2].End(xlDown))
Obj = Round(C, 2): Msg = "": ComponeSuma_op
Select Case Msg = ""
Case True: ToHoja2
Case False: C.Offset(, 1) = Msg
End Select
Next C

Set Rng = Nothing
With Hoja2
Application.GoTo .[a1], True
.[a1:a3] = WorksheetFunction.Transpose(Array("Tiempo de", "proceso", Timer - Ini))
.[a3].NumberFormat = "0.000 ""seg"""
.UsedRange.EntireColumn.AutoFit
End With

Application.ScreenUpdating = True
End Sub

Private Sub ToHoja2()
Dim j%, k%

j = 3: k = 2 + Q

With Hoja2.[da1].End(xlToLeft)
[e2].Copy .Offset(, 4).Resize(2)
.Offset(, 4).Resize(2) = WorksheetFunction.Transpose(Array("Objetivo", Obj))
With .Offset(2, 2).Resize(1 + k - j, 3)
Range("a" & j, "c" & k).Copy .Cells
Range("a" & j, "d" & k).Delete xlShiftUp
End With
End With

End Sub

Private Sub ComponeSuma_op()
Dim j%, x%, k%, objParcial#
Dim Vec1, T%(), U#(), Vec2, Fil

If IsEmpty([c3]) Then
Msg = "Sin valores que analizar."
Exit Sub
End If

Set Rng = Range([c3], [c2].End(xlDown))

'Verifico objetivo fuera de alcance
If Round(WorksheetFunction.Sum(Rng), 2) < Obj Then
Msg = "El valor objetivo es mayor que la suma de los valores listados."
Exit Sub
End If

'Verifico objetivo mínimo
If Round(WorksheetFunction.Min(Rng), 2) > Obj Then
Msg = "El valor objetivo es menor que el menor de los valores listados."
Exit Sub
End If

'Verifico suma total
If Round(WorksheetFunction.Sum(Rng), 2) = Obj Then
Rng.Offset(, 1) = 1: Q = Rng.Count: Exit Sub
End If

Vec1 = Evaluate("TRANSPOSE(SMALL(100*" & _
Rng.Address & " + (ROW(" & _
Rng.Address & ")/1000), ROW(1:" & _
Rng.Count & ")))")

x = 1 + UBound(Vec1)
ReDim Fil(1 To x)
ReDim Vec2(1 To x)

Vec2(1) = 0
For k = 2 To x
objParcial = Vec1(k - 1)
Vec2(k) = Int(objParcial) / 100
Fil(k) = 1000 * objParcial Mod 1000
Next k

Q = 1

'---
S00:
'---
ReDim T(1 To Q): ReDim U(1 To Q)
j = 1: x = 1 + UBound(Vec2)
Vec1 = Vec2

'---
S01:
'---
Do
objParcial = Round(Obj - WorksheetFunction.Sum(U), 2)
ReDim Preserve Vec1(1 To x - 1)
x = WorksheetFunction.Match(objParcial, Vec1, 1)
If x = 1 Then Exit Do
If j = 1 Then
ReDim Preserve Vec1(1 To x)
If Round(WorksheetFunction.Sum(Vec1), 2) < Obj Then GoTo noCombinations
End If
T(j) = x: U(j) = Vec2(x)
If U(j) = objParcial Then GoTo TargetFound
objParcial = WorksheetFunction.Sum(U)
For k = 1 To Q - j
If x - k = 1 Then Exit For
objParcial = objParcial + Vec2(x - k)
Next k
objParcial = Round(objParcial, 2)
If objParcial < Obj Then
Do While j > 1
If T(j - 1) - T(j) > 1 Then Exit Do
j = j - 1
Loop
Exit Do
End If
j = j + 1
If j > Q Then
j = j - 1: Exit Do
End If
Loop
'---------------------------

j = j - 1

'---
S02:
'---
If j = 0 Then GoTo OtroQ
T(j) = T(j) - 1
If T(j) = 1 Then
j = j - 1: GoTo S02
End If
U(j) = Vec2(T(j))
x = T(j)
Vec1 = Vec2
ReDim Preserve T(1 To j)
ReDim Preserve U(1 To j)
ReDim Preserve T(1 To Q)
ReDim Preserve U(1 To Q)

j = 1 + j: GoTo S01

'-----
OtroQ:
'-----
Q = 1 + Q
If Q < Rng.Count Then GoTo S00

'------
noCombinations:
'------
Msg = "No se encontró combinación."
GoTo Fin

'----------
TargetFound:
'----------
For j = 1 To Q
Cells(Fil(T(j)), "d") = 1
Next j
Rng.Offset(, -2).Resize(, 4).Sort [d3], xlAscending, Header:=xlNo

Fin:
Erase Vec1, T, U, Vec2, Fil

End Sub

Prueba así:

Dim Rng As Range
Dim Obj#, Msg$, Q%
Sub ComponeSuma()
'Dim C As Range, Ini As Double
If Not IsNumeric([c3]) Or IsEmpty([c3]) Then Exit Sub
If WorksheetFunction.CountBlank(Range([c3], [c65536].End(xlUp))) > 0 Then
MsgBox "El rango de datos contiene" & vbLf & "celdas en blanco."
Exit Sub
End If
With Range([e2], [e1000].End(xlUp))
If WorksheetFunction.Count(.Cells) = 0 Then
MsgBox "Debe establecer -al menos- un objetivo."
Exit Sub
End If
Application.ScreenUpdating = False
.Sort [e2], xlAscending, Header:=xlYes
End With
Ini = Timer
Range("d:d,f:f").ClearContents
Hoja2.UsedRange.EntireColumn.Delete Shift:=xlToLeft
For Each C In Range([e3], [e2].End(xlDown))
Obj = Round(C, 2): Msg = "": ComponeSuma_op
Select Case Msg = ""
Case True: ToHoja2
Case False: C.Offset(, 1) = Msg
End Select
Next C
Set Rng = Nothing
With Hoja2
Application.GoTo .[a1], True
.[a1:a3] = WorksheetFunction.Transpose(Array("Tiempo de", "proceso", Timer - Ini))
.[a3].NumberFormat = "0.000 ""seg"""
.UsedRange.EntireColumn.AutoFit
End With
Application.ScreenUpdating = True
End Sub
Private Sub ToHoja2()
'Dim j%, k%
j = 3: k = 2 + Q
With Hoja2.[da1].End(xlToLeft)
[e2].Copy .Offset(, 4).Resize(2)
.Offset(, 4).Resize(2) = WorksheetFunction.Transpose(Array("Objetivo", Obj))
With .Offset(2, 2).Resize(1 + k - j, 3)
Range("a" & j, "c" & k).Copy .Cells
Range("a" & j, "d" & k).Delete xlShiftUp
End With
End With
End Sub
Private Sub ComponeSuma_op()
'Dim j%, x%, k%, objParcial#
Dim Vec1, T%(), U#(), Vec2, Fil
If IsEmpty([c3]) Then
Msg = "Sin valores que analizar."
Exit Sub
End If
Set Rng = Range([c3], [c2].End(xlDown))
'Verifico objetivo fuera de alcance
If Round(WorksheetFunction.Sum(Rng), 2) < Obj Then
Msg = "El valor objetivo es mayor que la suma de los valores listados."
Exit Sub
End If
'Verifico objetivo mínimo
If Round(WorksheetFunction.Min(Rng), 2) > Obj Then
Msg = "El valor objetivo es menor que el menor de los valores listados."
Exit Sub
End If
'Verifico suma total
If Round(WorksheetFunction.Sum(Rng), 2) = Obj Then
Rng.Offset(, 1) = 1: Q = Rng.Count: Exit Sub
End If
Vec1 = Evaluate("TRANSPOSE(SMALL(100*" & _
Rng.Address & " + (ROW(" & _
Rng.Address & ")/1000), ROW(1:" & _
Rng.Count & ")))")
x = 1 + UBound(Vec1)
ReDim Fil(1 To x)
ReDim Vec2(1 To x)
Vec2(1) = 0
For k = 2 To x
objParcial = Vec1(k - 1)
Vec2(k) = Int(objParcial) / 100
Fil(k) = 1000 * objParcial Mod 1000
Next k
Q = 1
'---
S00:
'---
ReDim T(1 To Q): ReDim U(1 To Q)
j = 1: x = 1 + UBound(Vec2)
Vec1 = Vec2
'---
S01:
'---
Do
objParcial = Round(Obj - WorksheetFunction.Sum(U), 2)
ReDim Preserve Vec1(1 To x - 1)
x = WorksheetFunction.Match(objParcial, Vec1, 1)
If x = 1 Then Exit Do
If j = 1 Then
ReDim Preserve Vec1(1 To x)
If Round(WorksheetFunction.Sum(Vec1), 2) < Obj Then GoTo noCombinations
End If
T(j) = x: U(j) = Vec2(x)
If U(j) = objParcial Then GoTo TargetFound
objParcial = WorksheetFunction.Sum(U)
For k = 1 To Q - j
If x - k = 1 Then Exit For
objParcial = objParcial + Vec2(x - k)
Next k
objParcial = Round(objParcial, 2)
If objParcial < Obj Then
Do While j > 1
If T(j - 1) - T(j) > 1 Then Exit Do
j = j - 1
Loop
Exit Do
End If
j = j + 1
If j > Q Then
j = j - 1: Exit Do
End If
Loop
'---------------------------
j = j - 1
'---
S02:
'---
If j = 0 Then GoTo OtroQ
T(j) = T(j) - 1
If T(j) = 1 Then
j = j - 1: GoTo S02
End If
U(j) = Vec2(T(j))
x = T(j)
Vec1 = Vec2
ReDim Preserve T(1 To j)
ReDim Preserve U(1 To j)
ReDim Preserve T(1 To Q)
ReDim Preserve U(1 To Q)
j = 1 + j: GoTo S01
'-----
OtroQ:
'-----
Q = 1 + Q
If Q < Rng.Count Then GoTo S00
'------
noCombinations:
'------
Msg = "No se encontró combinación."
GoTo Fin
'----------
TargetFound:
'----------
For j = 1 To Q
Cells(Fil(T(j)), "d") = 1
Next j
Rng.Offset(, -2).Resize(, 4).Sort [d3], xlAscending, Header:=xlNo
Fin:
Erase Vec1, T, U, Vec2, Fil
End Sub

Me arroja desbordamiento en esta línea, la que puse con negrita

For k = 2 To x
objParcial = Vec1(k - 1)
Vec2(k) = Int(objParcial) / 100
Fil(k) = 1000 * objParcial Mod 1000
Next k
Q = 1
'---
S00:

Dante te envié el archivo por e-mail, para ver si se puede modificar