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

1 Respuesta

238.415 pts.
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