Crear una función de Interpolación en VBA (Excel)

De nuevo molestando
Lo que quiero realizar ahora es crean una función personalizada utilizando el método de interpolación no-lineal de LaGrange, teniendo mi lista de datos (x, y), en este caso como ejemplo estoy usando las columnas DE y E, y las filas de la 12 a 19
            D E
12 x y
13 0 13.96
14 4 14.36
15 8 14.96
16 12 15.92
17 16 17.4
18 18 18.52
19 20 20
Entonces lo que quiero hacer es que en una celda cualquiera (tomando como ejemplo la celda E7) pueda escribir la función "=interpolación(x, y_conocido, x, conocido)"
Siendo:
X un valor cualquiera tomando como ejemplo 17.5 (escrita en cualquier celda, para los motivos de ejemplo escrita en la celda D7)
Y_conocido: seleccionando las celdas E13:E19
y_conocido: seleccionando las celdas D13:D19
Por lo que el resultado de la función escrita en la celda E7 sería "=D7, E13:E19, D13:D19" y dando un resultado más o menos de 18.208
Entonces quiero crear un modulo, en el cual este escrito el código, como por ejemplo
Public Function interpolacion..
...
...
...
End Function
Estuve buscado y estudiando cómo crear lo que quiero, pero se me ha complicado, encontré un código que realiza la operación que quiero es muy bueno, pero no es tan flexible, ya que las celdas están fijas y tengo que estar escribiendo, luego seleccionando el rango (x, y) conocido y al final apretar el botón para que realice el algoritmo,
Este es el código
Private Sub CommandButton1_Click()
    Dim R As Range
    Dim n, m, i, j As Integer   'constantes internas
    Dim x() As Double           ' matriz dinámica
    Dim y() As Double           ' se ajustará a la selección de datos
    Dim Lkn, valorX, suma As Double
'En el rango R guardamos el rango seleccionado:
    Set R = Selection
    n = R.Rows.Count     ' Número de filas
    m = R.Columns.Count  ' Número de columnas
'Chequear que se hayan seleccionado los datos de la tabla
    If n > 1 And m = 2 Then
       'nada pasa, todo bien
    Else
      MsgBox ("Debe seleccionar los datos")
      Exit Sub        ' salimos de la subrutina
    End If
    ReDim x(n) ' vector x tiene ahora n campos
    ReDim y(n)
        valorX = Cells(7, 4)    'Valor a calcular
        suma = 0                'inicializa para acumular
        For i = 1 To n      'entra los datos de columna de los Xi's y los Yi's, inicia en 1
            x(i) = R(i, 1)  'aquí, iniciamos desde X1, es decir el x0 de la teoría, es x1
            y(i) = R(i, 2)  'aquí, iniciamos desde Y1, es decir el Y0 de la teoría, es Y1
        Next i
'Empieza el algoritmo
        For j = 1 To n
            Lkn = y(j)   'inicia cálculo de Lkn
            For i = 1 To n  'calculamos Lkn(valorX)
                If j <> i Then
                    Lkn = Lkn * (valorX - x(i)) / (x(j) - x(i)) 'Lkn evaluado en valorX
                End If
            Next i
            suma = suma + Lkn
        Next j
        Cells(7, 5) = suma
'Termina el algoritmo
End Sub

1 Respuesta

Respuesta
1
He convertido el procedimiento en función y la he llamado 'prueba':
Public Function prueba(R As Range) As Variant
    Dim n As Integer, m As Integer, i As Integer, j As Integer      'constantes internas
    Dim x() As Double           ' matriz dinámica
    Dim y() As Double           ' se ajustará a la selección de datos
    Dim Lkn As Double, valorX As Double, suma As Double
'En el rango R guardamos el rango seleccionado:
    n = R.Rows.Count     ' Número de filas
    m = R.Columns.Count  ' Número de columnas
'Chequear que se hayan seleccionado los datos de la tabla
    If n > 1 And m = 2 Then
       'nada pasa, todo bien
    Else
      prueba = "Debe seleccionar los datos"
      Exit Function   ' salimos de la subrutina
    End If
    ReDim x(n)        ' vector x tiene ahora n campos
    ReDim y(n)
        valorX = Cells(7, 4)    'Valor a calcular
        suma = 0                'inicializa para acumular
        For i = 1 To n      'entra los datos de columna de los Xi's y los Yi's, inicia en 1
            x(i) = R(i, 1)  'aquí, iniciamos desde X1, es decir el x0 de la teoría, es x1
            y(i) = R(i, 2)  'aquí, iniciamos desde Y1, es decir el Y0 de la teoría, es Y1
        Next i
'Empieza el algoritmo
        For j = 1 To n
            Lkn = y(j)   'inicia cálculo de Lkn
            For i = 1 To n  'calculamos Lkn(valorX)
                If j <> i Then
                    Lkn = Lkn * (valorX - x(i)) / (x(j) - x(i)) 'Lkn evaluado en valorX
                End If
            Next i
            suma = suma + Lkn
        Next j
        prueba = suma
'Termina el algoritmo
End Function
La sintaxis para llamar a la función desde una celda es
=prueba(rango)
Donde rango, en el ejemplo que pones, sería D13:E19.
La función parece estar bien porque devuelve el mismo resultado que le procedimiento: 18,2084698867798
Hola experto, en parte me gusto la respuesta y la rapidez en que lo hiciste, así que muchas gracias, pero tengo problemas, ya que en el código el valor a calcular "valorX = Cells(7, 4)" es fijo, esto quiere decir es que la variable a calcular siempre estará en la misma fila, lo que pretendo que realice es que haga la operación como la función predeterminada de Excel llamada PRONOSTICO, =(x, conocido_y, conocido_x), donde puedo escoger una valor x de cualquier celda, el rango de x y el rango y de otros grupo de celdas.
Lo que me di cuenta también es que si cambio el valor a calcular, tengo que apretar F2 y luego intro a la celda donde se encuentra la función creada =prueba(x, y)
De antemano gracias de nuevo
Lo único que tienes que hacer es añadir otro argumento a la función:
Public Function prueba(R As Range, ValorX As Double) As Variant
    'Dim R As Range
    Dim n As Integer, m As Integer, i As Integer, j As Integer      'constantes internas
    Dim x() As Double           ' matriz dinámica
    Dim y() As Double           ' se ajustará a la selección de datos
    Dim Lkn As Double, suma As Double
'En el rango R guardamos el rango seleccionado:
    n = R.Rows.Count     ' Número de filas
    m = R.Columns.Count  ' Número de columnas
'Chequear que se hayan seleccionado los datos de la tabla
    If n > 1 And m = 2 Then
       'nada pasa, todo bien
    Else
      prueba = "Debe seleccionar los datos"
      Exit Function   ' salimos de la subrutina
    End If
    ReDim x(n)        ' vector x tiene ahora n campos
    ReDim y(n)
        suma = 0                'inicializa para acumular
        For i = 1 To n      'entra los datos de columna de los Xi's y los Yi's, inicia en 1
            x(i) = R(i, 1)  'aquí, iniciamos desde X1, es decir el x0 de la teoría, es x1
            y(i) = R(i, 2)  'aquí, iniciamos desde Y1, es decir el Y0 de la teoría, es Y1
        Next i
'Empieza el algoritmo
        For j = 1 To n
            Lkn = y(j)   'inicia cálculo de Lkn
            For i = 1 To n  'calculamos Lkn(valorX)
                If j <> i Then
                    Lkn = Lkn * (ValorX - x(i)) / (x(j) - x(i)) 'Lkn evaluado en valorX
                End If
            Next i
            suma = suma + Lkn
        Next j
        prueba = suma
'Termina el algoritmo
End Function
La sintaxis sería:
=prueba(rango,valor)

Añade tu respuesta

Haz clic para o

Más respuestas relacionadas

Suma de celdas con color en formato condicional

Me gustaría sumar celdas con color determinado, que tienen formato condicional. He intentado hacer sumas con VBA, pero lo que he conseguido no diferencia colores y me suma todas los celdas. Paso link con archivo detallado de lo que busco conseguir:...
1 respuesta

¿Cómo diseñar Macro para colorear filas por coincidencias?

Para todos y complacido de poder participar con mi inquietud y ojalá me puedan ayudar. Lo cierto es que soy novato (muy novato) y estoy en una carrera contra el tiempo que no me permite dedicarle mucho tiempo. Es por ello que acudo a pedir ayuda. Y...
1 respuesta

Png en un form de visual basic

Ya se q se se respondio a esta pregunta, diciendo q habia q entrar a proyecto | referencias y ahi se tenia q buscar: paintx.dll ... Solo q cuando yo lo hice no encontre "paint.dll" asi q me lo descargue de http://www.paintlib.de/paintlib/ (nose si...
1 respuesta

Buscar en rango aquellas celdas que sumen valor dado

Encontré estas pregunta y respuesta aquí en el foro que son por un problema casi idéntico a uno que yo tengo. La respuesta que dio el experto es muy buena, pero funciona sólo identificando dos celdas que cumplen la restricción, y no sé cómo modificar...
2 respuestas

Prorrateo en excel

No estoy seguro que su nombre sea prorrateo, pero bueno así lo llamo yo. Existe alguna función o que haga algo más o menos así: N = (N1 * C1 + N2 * C2 + ... Nn * Cn)/ (N1 + N2 + ... Nn) (Siendo N y C, cualquiera celda!). No he encontrado ni podido...
1 respuesta

Problema al multiplicar dos marices

Disculpa mi molestia y antes que nada agradezco tu colaboración para con los usuarios, mi consulta es la siguiente: Estoy realizando una aplicación que sume, reste y multiplique matrices. Cuando multiplico matrices de igual dimensiones, es decir 2 x...
1 respuesta

Redimensionar matriz bidimensional

Disculpa la molestia pero resulta que estoy realizando una guía para almacenar personas con dirección, nombre, apellido y teléfono y uso una matriz bidireccional dinámica ya que esa es la consigna. Y cuando ya tengo una persona cargada no puedo...
1 respuesta

Llenas una matriz usando otra sin repetir datos

Tengo un arreglo con valores 8|8|8|8|9|8|8|1|1 Por ejemplo Ahora lo que necesito es guardar los valores en otro arreglo pero sin repetirse Es decir que quede 8|9|1 El primer arreglo es dinámico por lo que el segundo también puede variar no se como...
1 respuesta

Buscar datos en rejilla

Tengo un control msflexgrid cargado de datos, y me gustaría saber como puedo hacer una búsqueda de una determinada cadena de caracteres o de datos numéricos en la rejilla.
2 respuestas