Modificar el código de la macro "Buscar en rango aquellas celdas que sumen valor dado"
Estimados,
Esperando me puedan ayudar con el caso que anteriormente expusieron y que es muy buen aporte, me gustaría saber como poder editar dicho código de la macro en Excel pero para que haga lo siguiente:
Ejemplo:
Tengo la Lista A y la Lista B
Si yo tengo un VALOR OBJETIVO y mi NUMERO DE VALOR tenga alguno de los siguientes casos:
Caso 1
Si NUMERO DE VALOR=3
2 valores de la Lista A + 1 valor de la Lista B
ue al SUMARLOS llegue al VALOR OBJETIVO y en una columna me en listen todas las combinaciones posibles que sumen el VALOR OBJETIVO y este VALOR OBJETIVO pude ser igual o estar arriba un 10%.
Caso 2
Si NUMERO DE VALOR=5
3 valores de la Lista A + 2 valor de la Lista B
ue al SUMARLOS llegue al VALOR OBJETIVO y en una columna me en listen todas las combinaciones posibles que sumen el VALOR OBJETIVO y este VALOR OBJETIVO pude ser igual o estar arriba un 10%..
Nota: En este código solo me muestra 1 resultado en la F1. Yo quiero que me enliste todos los casos posibles que lleguen al valor objetivo o que tenga tenga un go 0% al 10%
De antemano gracias.!!!
Este es el código que aquí vi anteriormente:
Sub combNnum3()
'Modificar referencias en hoja:
IniRango = "D4" 'Inicio de lista de números
IniLista = "F1" 'Inicio de lista de resultados posibles
resObjet = "D23" 'Celda con resultado a buscar
numValores = "D24" 'Número valores a sumar
'----------------------------
Set IniLista = Range(IniLista)
vCol = IniLista.Column
vFila = IniLista.Row
'carga de valores a una matriz
Dim ListNum()
ReDim Preserve ListNum(0)
ListNum(0) = 0
Nro = 1
Set IniRango = Range(IniRango)
IniRango.Select
Do While Not IsEmpty(ActiveCell)
ReDim Preserve ListNum(Nro)
ListNum(Nro) = ActiveCell.Value
Nro = Nro + 1
ActiveCell.Offset(1).Select
Loop
IniLista.Select
IniLista.CurrentRegion.ClearContents
'Inicia ciclo de combinaciones
combinar ListNum, _
Range(numValores).Value, _
Range(resObjet).Value, _
ActiveSheet, CLng(vFila), CInt(vCol)
Set IniLista = Nothing
Set IniRango = Nothing
End Sub
Sub combinar(lista, aSumar As Integer, _
objetivo As Integer, hoja As Worksheet, _
Optional filaIni As Long = 1, Optional colores As Integer = 6)
Dim lstAsum() As Integer
Dim tamLista As Integer
Dim suma As Integer
Dim resp As String
Dim itera As Double
Dim pos As Integer
tamLista = UBound(lista) + 1
If tamLista > aSumar Then
ReDim lstAsum(aSumar - 1)
For i = 0 To aSumar - 1
lstAsum(i) = i
Next
fin = False
Do Until (fin)
itera = itera + 1
'hoja.Cells(itera,colores+1).Value = lista(lstAsum(0) + 1) & " " & _
lista(lstAsum(1) + 1) & " " & _
lista(lstAsum(2) + 1)
suma = 0
resp = ""
For i = 0 To UBound(lstAsum)
suma = suma + lista(lstAsum(i) + 1)
resp = resp & "+" & lista(lstAsum(i) + 1)
Next
If suma = objetivo Then
hoja.Cells(filaIni, colores).Value = resp
filaIni = filaIni + 1
End If
pos = aSumar
inc = aSumar
ok = False
Do Until (ok = True Or (pos - inc) >= aSumar Or fin = True)
If (lstAsum(pos - inc) + 1 >= tamLista - inc) Then
If inc = aSumar Then
fin = True
Else
lstAsum(pos - inc - 1) = lstAsum(pos - inc - 1) + 1
Do Until (inc < 1)
lstAsum(pos - inc) = lstAsum(pos - inc - 1) + 1
inc = inc - 1
Loop
End If
Else
If (pos - inc) >= aSumar - 1 Then
lstAsum(pos - inc) = lstAsum(pos - inc) + 1
ok = True
End If
End If
inc = inc - 1
Loop
Loop
MsgBox "Nº Iteraciones: " & itera
End If
End Sub
