Bucle encuentre valor más cercano a cero
Hola,
tengo una pregunta creo que facilita pero no consigo resolverla.
Quiero hacer en VB un bucle que ejecute la función Calculate hasta que encuentre el valor dado en una celda.
On Error GoTo Fin
Range("C3").Select
Do Until (Range("G3") = 0)
Calculate
Loop
Fin:
Pero quiero que si no se encuentra el valor 0, el bucle no siga indefinidamente, sino que se pare en el más cercano a 0, por arriba o por abajo.
¿Cómo se haría?
Gracias
Miguel73
tengo una pregunta creo que facilita pero no consigo resolverla.
Quiero hacer en VB un bucle que ejecute la función Calculate hasta que encuentre el valor dado en una celda.
On Error GoTo Fin
Range("C3").Select
Do Until (Range("G3") = 0)
Calculate
Loop
Fin:
Pero quiero que si no se encuentra el valor 0, el bucle no siga indefinidamente, sino que se pare en el más cercano a 0, por arriba o por abajo.
¿Cómo se haría?
Gracias
Miguel73
1 Respuesta
Respuesta de Victor Perdomo
1
Esta como compleja la pregunta, ¿me puedes decir que hace la función calculate?
Tengo una lista con aprox. 100 valores y con calculate, busca una suma de valores que coincide con un numero indicado.
Ejemplo:
Buscar suma de numero que sea igual a 10 entre los siguientes:
1 2 3 4 5 6 7 8 9
Repuesta: 1 + 4 + 5, o 1 + 9
El ejemplo me lo baje de internet y funciona tal que asi:
Hay dos columnas, una con los numeros a sumar y otra, al lado, con el valor =aleatorio.entre(1;0)
Después hay en otra celda una función Sumaproducto de las dos columnas y usa la función Solver.
Según me parece, calculate hace que empiece a usarse el calculo.
El programa funciona bien, pero tengo el problema de que si no me encuentra la solución, el bucle no para. Me interesaría que si no la encuentra, buscase el valor más próximo.
Gracias
Ejemplo:
Buscar suma de numero que sea igual a 10 entre los siguientes:
1 2 3 4 5 6 7 8 9
Repuesta: 1 + 4 + 5, o 1 + 9
El ejemplo me lo baje de internet y funciona tal que asi:
Hay dos columnas, una con los numeros a sumar y otra, al lado, con el valor =aleatorio.entre(1;0)
Después hay en otra celda una función Sumaproducto de las dos columnas y usa la función Solver.
Según me parece, calculate hace que empiece a usarse el calculo.
El programa funciona bien, pero tengo el problema de que si no me encuentra la solución, el bucle no para. Me interesaría que si no la encuentra, buscase el valor más próximo.
Gracias
Creo que la única forma de ayudarte es que me envíes una copia a [email protected]
Te lo envío ahora mismo
Te comento algo, el código esta bien, el problema radica en algo, al ser números aleatorios es poco probable que tengas una respuesta rápidamente, es más si dejaras un rato la macro andando muy probablemente tendrías una respuesta, quizás en 5 min o 1 hora o un día.
Si te das cuenta al ser números del 1 al 20 existen muchas combinaciones probables, desde 00000000000000000000 hasta 11111111111111111111, en este puntopuedes manejar las combinaciones como números decimales.
00000000000000000001=1
00000000000000000010
00000000000000000011
00000000000000000100
.
.
.
11111111111111111111=1.048.575
O sea hay 1.048.575 combinaciones probables, ademas el mayor numero que puedes buscar es 1+2+3+4.....+20=210
A partir de esto creo que es mejor tener controlado los numeros a buscar y no aleatoriamente. Te hice un código, para esto elimina los aleatorio. Entre(1,0) de la columna H. E inserta este código en un modulo. Básicamente son dos funciones, la función DecxBin, convierte un numero decimal a binario y lo pone en las ubicación que le hallamos indicado con f y c. La función Calcularx() Es la que tienes que llamar con tu botón, básicamente hace un ciclo desde 1 hasta 1.048.575 y los convierte a binario, la función sumar. Producto ira calculando el resultado, en el momento que encuentre una solución te preguntara si deseas buscar otra.
Pero tienes que tener en cuenta algo, el tiempo que tarda en buscar es exponencial al numero de bits del numero binario, o sea para buscar soluciones del numero 10 puede tardar un segundo pero para solucionar el 86 tardara quizás 30 segundos, te cuento que el mayor numero 210 que tiene solo una solución, quizás tarde entre 30 y 40 minutos XD. De todos modos usalo y me cuentas ;).
Private Function DecxBin(numero As Long, f As Integer, c As Integer) As String
If numero <= 2 Then 'Caso Base
DecxBin = (numero Mod 2)
Cells(f, c) = DecxBin
Else 'Caso Recursivo
DecxBin = DecxBin(numero \ 2, f + 1, c) & numero Mod 2
Cells(f, c) = numero Mod 2
End If
End Function
Sub Calcularx()
Application.ScreenUpdating = False
Range("h6:h25").Value = "0"
Dim i As Long
i = 1
While i <= 1048575
Call DecxBin(i, 6, 8)
If (Range("G3") = 0) Then
Application.ScreenUpdating = True
If (MsgBox("Solucion encontrada. Desea buscar otra solucion?", 1)) = 2 Then
Exit Sub
End If
Application.ScreenUpdating = False
End If
i = i + 1
Wend
Application.ScreenUpdating = True
End Sub
Si te das cuenta al ser números del 1 al 20 existen muchas combinaciones probables, desde 00000000000000000000 hasta 11111111111111111111, en este puntopuedes manejar las combinaciones como números decimales.
00000000000000000001=1
00000000000000000010
00000000000000000011
00000000000000000100
.
.
.
11111111111111111111=1.048.575
O sea hay 1.048.575 combinaciones probables, ademas el mayor numero que puedes buscar es 1+2+3+4.....+20=210
A partir de esto creo que es mejor tener controlado los numeros a buscar y no aleatoriamente. Te hice un código, para esto elimina los aleatorio. Entre(1,0) de la columna H. E inserta este código en un modulo. Básicamente son dos funciones, la función DecxBin, convierte un numero decimal a binario y lo pone en las ubicación que le hallamos indicado con f y c. La función Calcularx() Es la que tienes que llamar con tu botón, básicamente hace un ciclo desde 1 hasta 1.048.575 y los convierte a binario, la función sumar. Producto ira calculando el resultado, en el momento que encuentre una solución te preguntara si deseas buscar otra.
Pero tienes que tener en cuenta algo, el tiempo que tarda en buscar es exponencial al numero de bits del numero binario, o sea para buscar soluciones del numero 10 puede tardar un segundo pero para solucionar el 86 tardara quizás 30 segundos, te cuento que el mayor numero 210 que tiene solo una solución, quizás tarde entre 30 y 40 minutos XD. De todos modos usalo y me cuentas ;).
Private Function DecxBin(numero As Long, f As Integer, c As Integer) As String
If numero <= 2 Then 'Caso Base
DecxBin = (numero Mod 2)
Cells(f, c) = DecxBin
Else 'Caso Recursivo
DecxBin = DecxBin(numero \ 2, f + 1, c) & numero Mod 2
Cells(f, c) = numero Mod 2
End If
End Function
Sub Calcularx()
Application.ScreenUpdating = False
Range("h6:h25").Value = "0"
Dim i As Long
i = 1
While i <= 1048575
Call DecxBin(i, 6, 8)
If (Range("G3") = 0) Then
Application.ScreenUpdating = True
If (MsgBox("Solucion encontrada. Desea buscar otra solucion?", 1)) = 2 Then
Exit Sub
End If
Application.ScreenUpdating = False
End If
i = i + 1
Wend
Application.ScreenUpdating = True
End Sub
La he estado probando y funciona pero lo que no hace es, en el caso de que no exista solución, buscar el numero la solución más cercana.
He probado solo con tres números modificando el código y no encuentra nada.
¿La función que has hecho buscaría la solución más cercana si no encuentra la solución exacta o no?
He probado solo con tres números modificando el código y no encuentra nada.
¿La función que has hecho buscaría la solución más cercana si no encuentra la solución exacta o no?
No entiendo cuando dices solución más cercana, todos los números entre 0 y 210 tienen solución.
Dime un numero que no tenga solución
Dime un numero que no tenga solución
El archivo que te mande NO tiene los datos correctos (importes). Pero imaginate que pones los importes: 10, 421, -30, 18, 498 ... y tienes que buscar combinaciones que se aproximen a 233. A lo mejor no existe solución exacta, pero si se pueden buscar la combinación que más se aproxime.
Siento no haberte enviado el ejemplo con los datos correctos.
Espero
Siento no haberte enviado el ejemplo con los datos correctos.
Espero
De verdad que tu pregunta me tomo tiempo, es bastante interesante, y logre realizar un código que hace exactamente lo que quieres. La única limitante, es el tiempo que puede durar al realizar cálculos con muchas variables, porque como te dije puede llegar a realizar con 20 datos 1.048.575 iteraciones, y en cada iteración hace bastantes cálculos lo que puede producir mucho tiempo de espera.
En el siguiente link esta la hoja funcionando:
http://rapidshare.com/files/383751205/Macro_suma_.xls
De todas maneras a continuación pongo el código, la deje por defecto con 15 datos y no con 20, pero si quieres poner más datos solo modifica los rangos que están al comienzo del código.
Sub Calcularx()
Dim i, ifin As Long
Dim rango, celda As String
Dim menor As Double 'Guardara el menor de las soluciones
Dim menori As Long 'Guardara la combinacion para el menor
celda = "G3" 'celda donde estara la diferencia
celda2 = "h3" 'celda donde estara el sumaproducto
rango = "h6:h15" 'Rango donde estaran los 1 y 0
rango2 = "f6:f15" 'Rango donde estaran los valores
i = 1 'primera posible solucion 1
ifin = Numbinario(Range(rango).Rows.Count) 'ultima posible solucion
Range(celda2).FormulaLocal = "=SUMAPRODUCTO(" & rango2 & ";" & rango & ")"
Application.ScreenUpdating = False
While i <= ifin
Range(rango).Value = "0"
Call DecxBin(i, Range(rango).Row, Range(rango).Column)
If (i = 1) Then
menor = Abs(Range(celda).Value)
menori = i
End If
If (Abs(Range(celda).Value) < menor) Then
menor = Abs(Range(celda).Value)
menori = i
End If
If (Range(celda) = 0) Then
Application.ScreenUpdating = True
If (MsgBox("Solucion encontrada. Desea buscar otra solucion?", 1)) = 2 Then
Exit Sub
End If
Application.ScreenUpdating = False
End If
i = i + 1
Wend
Range(rango).Value = "0"
Call DecxBin(menori, Range(rango).Row, Range(rango).Column)
Application.ScreenUpdating = True
'Application.Calculation = xlAutomatic
MsgBox ("Solucion exacta no encontrada." & vbCrLf & "Solucion mas cercana:")
End Sub
Function Numbinario(n As Integer) As Long
Dim a As Long
For i = 0 To n - 1
a = a + 2 ^ i
Next
Numbinario = a
End Function
Public Function DecxBin(ByVal numero As Long, f As Integer, c As Integer) As String
If numero <= 2 Then 'Caso Base
DecxBin = (numero \ 2) & (numero Mod 2)
Cells(f, c) = (numero Mod 2)
If (numero \ 2) = 1 Then Cells(f + 1, c) = 1
Else 'Caso Recursivo
DecxBin = DecxBin(numero \ 2, f + 1, c) & numero Mod 2
Cells(f, c) = numero Mod 2
End If
End Function
En el siguiente link esta la hoja funcionando:
http://rapidshare.com/files/383751205/Macro_suma_.xls
De todas maneras a continuación pongo el código, la deje por defecto con 15 datos y no con 20, pero si quieres poner más datos solo modifica los rangos que están al comienzo del código.
Sub Calcularx()
Dim i, ifin As Long
Dim rango, celda As String
Dim menor As Double 'Guardara el menor de las soluciones
Dim menori As Long 'Guardara la combinacion para el menor
celda = "G3" 'celda donde estara la diferencia
celda2 = "h3" 'celda donde estara el sumaproducto
rango = "h6:h15" 'Rango donde estaran los 1 y 0
rango2 = "f6:f15" 'Rango donde estaran los valores
i = 1 'primera posible solucion 1
ifin = Numbinario(Range(rango).Rows.Count) 'ultima posible solucion
Range(celda2).FormulaLocal = "=SUMAPRODUCTO(" & rango2 & ";" & rango & ")"
Application.ScreenUpdating = False
While i <= ifin
Range(rango).Value = "0"
Call DecxBin(i, Range(rango).Row, Range(rango).Column)
If (i = 1) Then
menor = Abs(Range(celda).Value)
menori = i
End If
If (Abs(Range(celda).Value) < menor) Then
menor = Abs(Range(celda).Value)
menori = i
End If
If (Range(celda) = 0) Then
Application.ScreenUpdating = True
If (MsgBox("Solucion encontrada. Desea buscar otra solucion?", 1)) = 2 Then
Exit Sub
End If
Application.ScreenUpdating = False
End If
i = i + 1
Wend
Range(rango).Value = "0"
Call DecxBin(menori, Range(rango).Row, Range(rango).Column)
Application.ScreenUpdating = True
'Application.Calculation = xlAutomatic
MsgBox ("Solucion exacta no encontrada." & vbCrLf & "Solucion mas cercana:")
End Sub
Function Numbinario(n As Integer) As Long
Dim a As Long
For i = 0 To n - 1
a = a + 2 ^ i
Next
Numbinario = a
End Function
Public Function DecxBin(ByVal numero As Long, f As Integer, c As Integer) As String
If numero <= 2 Then 'Caso Base
DecxBin = (numero \ 2) & (numero Mod 2)
Cells(f, c) = (numero Mod 2)
If (numero \ 2) = 1 Then Cells(f + 1, c) = 1
Else 'Caso Recursivo
DecxBin = DecxBin(numero \ 2, f + 1, c) & numero Mod 2
Cells(f, c) = numero Mod 2
End If
End Function
Estuve verificando los tiempos, y realmente es menos de lo que pensaba, no son 40 min para 20 datos, son solamente 4 min para analizar todas las combinaciones.
