VBA.Mania

Function rr_r(input_col As Range, output_col As Range, Zjw As Double, w As Double) As Double
   Dim delta As Double, x As Double, wyraz As Double, i As Integer, Zjx As Double, Zjxa As Double, Zjxb As Double, calka As Double, a As Double, b As Double, n As Integer
   Const Pi As Double = 3.14159265358979
   a = 0#
   b = 1000000000#
   n = 1000
   rr_r = 0#
   calka = 0#
   delta = (b - a) / n
   x = a
   For i = 1 To n Step 2
   Zjx = cubic_spline(input_col, output_col, x)
   Zjxa = cubic_spline(input_col, output_col, x + delta)
   Zjxb = cubic_spline(input_col, output_col, x + 2 * delta)
   wyraz = yr(Zjw, Zjx, w, x) + 4 * yr(Zjw, Zjxa, w, x + delta) + yr(Zjw, Zjxb, w, x + 2 * delta)
   calka = calka + wyraz
   x = x + 2 * delta
   Next i
   rr_r = ((2 / Pi) * calka) * delta / 3
End Function

Function yr(Zjw As Double, Zjx As Double, w As Double, x As Double) As Double
   yr = (x * Zjx - w * Zjw) / (x ^ 2 - w ^ 2)
End Function

Sub Wypisz()
MsgBox rr_r(0.1, 1000000, 1000, Range("B2:B63"), Range("D2:D63"), -43.631, 0.1)
End Sub

Function rr_r(a As Double, b As Double, n As Integer, input_col As Range, output_col As Range, Zjw As Double, w As Double) As Double
   Dim delta As Double, x As Double, wyraz As Double, i As Integer, Zjx As Double, calka As Double
   rr_r = 0#
   calka = 0#
   delta = (b - a) / n
   x = a
   For i = 1 To n Step 2
   Zjx = cubic_spline(input_col, output_col, x)
   wyraz = yr(Zjw, Zjx, w, x) + 4 * yr(Zjw, Zjx, w, x + delta) + yr(Zjw, Zjx, w, x + 2 * delta)
   calka = calka + wyraz
   x = x + 2 * delta
   Next i
   rr_r = calka * delta / 3
End Function

Function Integral(F As String, a As Double, b As Double, n As Integer) As Double
   Dim delta As Double, x As Double, wyraz As Double, i As Integer
   Integral = 0#
   delta = (b - a) / n
   x = a
   For i = 1 To n Step 2
   wyraz = y(F, x) + 4 * y(F, x + delta) + y(F, x + 2 * delta)
   Integral = Integral + wyraz
   x = x + 2 * delta
   Next i
   Integral = Integral * delta / 3
End Function

Function rr_r(a As Double, b As Double, n As Integer, input_col As Range, output_col As Range, Zjw As Double, w As Double) As Double
   Dim delta As Double, x As Double, wyraz As Double, i As Integer
   rr_r = 0#
   delta = (b - a) / n
   x = a
   For i = 1 To n Step 2
   Zjx = cubic_spline(input_col, output_col, x)
   wyraz = yr(Zjw, Zjx, w, x) + 4 * yr(Zjw, Zjx, w, x + delta) + yr(Zjw, Zjx, w, x + 2 * delta)
   'w poniższej linii masz wywołanie rekurencyjne funkcji rr_r, ale ono
   'nie zadziała, bo nie podałeś argumentów dla funcji rr_r!!!!!
   rr_r = rr_r + wyraz
   x = x + 2 * delta
   Next i
   'w poniższej linii masz wywołanie rekurencyjne funkcji rr_r, ale ono
   'nie zadziała, bo nie podałeś argumentów dla funcji rr_r!!!!!
   rr_r = rr_r * delta / 3
End Function

Function yr(Zjw As Double, Zjx As Double, w As Double, x As Double) As Double
y = (x * Zjx - w * Zjw) / (x ^ 2 - w ^ 2)
End Function

Function yr(Zjw As Double, Zjx As Double, w As Double, x As Double) As Double
yr = (x * Zjx - w * Zjw) / (x ^ 2 - w ^ 2)
End Function

Function yr(Zjw As Double, Zjx As Double, w As Double, x As Double) As Double
   y = (x * Zjx - w * Zjw) / (x ^ 2 - w ^ 2)
End Function

Function rr_r(a As Double, b As Double, n As Integer, input_col As Range, output_col As Range, Zjw As Double, w As Double) As Double
   Dim delta As Double, x As Double, wyraz As Double, i As Integer
   rr_r = 0#
   delta = (b - a) / n
   x = a
   For i = 1 To n Step 2
   Zjx = cubic_spline(input_col, output_col, x)
   wyraz = yr(Zjw, Zjx, w, x) + 4 * yr(Zjw, Zjx, w, x + delta) + yr(Zjw, Zjx, w, x + 2 * delta)
   rr_r = rr_r + wyraz
   x = x + 2 * delta
   Next i
   rr_r = rr_r * delta / 3
End Function

'******************** Cubic_Spline by SRS1 Software ****************
'
'
' Version 1.01

Function cubic_spline(input_column As Range, _
                      output_column As Range, _
                      x As Range)

'Purpose: Given a data set consisting of a list of x values
' and y values, this function will smoothly interpolate
' a resulting output (y) value from a given input (x) value

' This counts how many points are in "input" and "output" set of data
Dim input_count As Integer
Dim output_count As Integer

input_count = input_column.Rows.Count
output_count = output_column.Rows.Count

' Next check to be sure that "input" # points = "output" # points
If input_count <> output_count Then
    cubic_spline = "Something's messed up! The number of indeces number of output_columnues don't match!"
    GoTo out
End If

ReDim xin(input_count) As Single
ReDim yin(input_count) As Single

Dim c As Integer

For c = 1 To input_count
xin(c) = input_column(c)
yin(c) = output_column(c)
Next c

'''''''''''''''''''''''''''''''''''''''
' values are populated
'''''''''''''''''''''''''''''''''''''''
Dim n As Integer 'n=input_count
Dim i, k As Integer 'these are loop counting integers
Dim p, qn, sig, un As Single
ReDim u(input_count - 1) As Single
ReDim yt(input_count) As Single 'these are the 2nd deriv values

n = input_count
yt(1) = 0
u(1) = 0

For i = 2 To n - 1
    sig = (xin(i) - xin(i - 1)) / (xin(i + 1) - xin(i - 1))
    p = sig * yt(i - 1) + 2
    yt(i) = (sig - 1) / p
    u(i) = (yin(i + 1) - yin(i)) / (xin(i + 1) - xin(i)) - (yin(i) - yin(i - 1)) / (xin(i) - xin(i - 1))
    u(i) = (6 * u(i) / (xin(i + 1) - xin(i - 1)) - sig * u(i - 1)) / p

    Next i

qn = 0
un = 0

yt(n) = (un - qn * u(n - 1)) / (qn * yt(n - 1) + 1)

For k = n - 1 To 1 Step -1
    yt(k) = yt(k) * yt(k + 1) + u(k)
Next k

''''''''''''''''''''
'now eval spline at one point
'''''''''''''''''''''
Dim klo, khi As Integer
Dim h, b, a As Single

' first find correct interval
klo = 1
khi = n
Do
k = khi - klo
If xin(k) > x Then
khi = k
Else
klo = k
End If
k = khi - klo
Loop While k > 1
h = xin(khi) - xin(klo)
a = (xin(khi) - x) / h
b = (x - xin(klo)) / h
y = a * yin(klo) + b * yin(khi) + ((a ^ 3 - a) * yt(klo) + (b ^ 3 - b) * yt(khi)) * (h ^ 2) / 6

cubic_spline = y

out:
End Function

Sub test()
  Dim w As Double, w1 As Double

  w = y1("x*y", 2, 3)

  w = Cos(0.5) * Exp(0.7)
  w1 = y1("cos(x)*exp(y)", 0.5, 0.7)
End Sub

Function y1(funkcja As String, x As Double, y As Double) As Double
  Dim xF As String

  If InStr(1, funkcja, "exp") > 0 Then
    xF = Replace(funkcja, "exp", "egze_begze")
    xF = Replace(Replace(xF, "x", _
          Replace(x, ",", ".")), "y", Replace(y, ",", "."))
    y1 = Evaluate(Replace(xF, "egze_begze", "exp"))
  Else
    y1 = Evaluate(Replace(Replace(funkcja, "x", _
          Replace(x, ",", ".")), "y", Replace(y, ",", ".")))
  End If
End Function

Function y(funkcja As String, x As Double) As Double
  Dim xF As String
  If InStr(1, funkcja, "exp") > 0 Then
    xF = Replace(funkcja, "exp", "egze_begze")
    xF = Replace(xF, "x", Replace(x, ",", "."))
    xF = Replace(xF, "egze_begze", "exp")
    y = Evaluate(xF)
  Else
    y = Evaluate(Replace(funkcja, "x", Replace(x, ",", ".")))
  End If
End Function

Function Integral(F As String, a As Double, b As Double, n As Integer) As Double
  Dim delta As Double, x As Double, wyraz As Double, i As Integer
  Integral = 0#
  delta = (b - a) / n
  x = a
  For i = 1 To n Step 2
  wyraz = y(F, x) + 4 * y(F, x + delta) + y(F, x + 2 * delta)
  Integral = Integral + wyraz
  x = x + 2 * delta
  Next i
  Integral = Integral * delta / 3
End Function

Sub test()
  Dim a As Double, pole As Double, P1 As Double
  P1 = WorksheetFunction.pi()
  'wartość funkcji dla Pi
  a = y("x*SIN(x)", P1)
  'pole powierzchni
  pole = Integral("x*sin(x)", 0, P1, 100)
End Sub

A1 x*sin(x)
A2 0
A3 =PI()
A4 100
A5 =Integral(A1;A2;A3;A4)

lub
=Integral("x*sin(x)";0;Pi();100)

Sub test()
  Dim a As Double
  a = y("x*SIN(x)", 1.43)
End Sub

Function y(funkcja As String, x As Double) As Double
  y = Evaluate(Replace(funkcja, "x", Replace(x, ",", ".")))
End Function