Вот полное решение для **параметрического тригонометрического ряда Фурье** без дифференцирования, с минимальным кодом:
## **Простейшая реализация параметрического ряда Фурье на VBA**
### **1. Основной модуль для вычисления коэффициентов Фурье**
```vba
' Module: modFourierSeries
Option Explicit
' Структура для хранения коэффициентов Фурье
Type FourierCoefficients
a0 As Double
a() As Double ' Коэффициенты при cos
b() As Double ' Коэффициенты при sin
End Type
' Вычисление коэффициентов Фурье для параметрической функции
' x(t), y(t) - массивы значений (t от 0 до 2π)
' n - количество гармоник
Public Sub ComputeFourierCoefficients(x() As Double, y() As Double, _
ByVal n As Long, _
ByRef coeffX As FourierCoefficients, _
ByRef coeffY As FourierCoefficients)
Dim Npoints As Long
Npoints = UBound(x)
' Инициализация коэффициентов
coeffX.a0 = 0
coeffY.a0 = 0
ReDim coeffX.a(1 To n)
ReDim coeffX.b(1 To n)
ReDim coeffY.a(1 To n)
ReDim coeffY.b(1 To n)
' Вычисление a0
Dim i As Long, k As Long
For i = 1 To Npoints
coeffX.a0 = coeffX.a0 + x(i)
coeffY.a0 = coeffY.a0 + y(i)
Next i
coeffX.a0 = coeffX.a0 / Npoints
coeffY.a0 = coeffY.a0 / Npoints
' Вычисление коэффициентов an, bn
Dim t As Double, cos_nt As Double, sin_nt As Double
For k = 1 To n
coeffX.a(k) = 0
coeffX.b(k) = 0
coeffY.a(k) = 0
coeffY.b(k) = 0
For i = 1 To Npoints
t = 2 * Application.WorksheetFunction.Pi() * (i - 1) / Npoints
cos_nt = Cos(k * t)
sin_nt = Sin(k * t)
coeffX.a(k) = coeffX.a(k) + x(i) * cos_nt
coeffX.b(k) = coeffX.b(k) + x(i) * sin_nt
coeffY.a(k) = coeffY.a(k) + y(i) * cos_nt
coeffY.b(k) = coeffY.b(k) + y(i) * sin_nt
Next i
coeffX.a(k) = 2 * coeffX.a(k) / Npoints
coeffX.b(k) = 2 * coeffX.b(k) / Npoints
coeffY.a(k) = 2 * coeffY.a(k) / Npoints
coeffY.b(k) = 2 * coeffY.b(k) / Npoints
Next k
End Sub
' Восстановление функции по коэффициентам Фурье
Public Function EvaluateFourierSeries(ByVal t As Double, _
coeff As FourierCoefficients, _
ByVal n As Long) As Double
Dim result As Double
result = coeff.a0 / 2
Dim k As Long
For k = 1 To n
result = result + coeff.a(k) * Cos(k * t) + coeff.b(k) * Sin(k * t)
Next k
EvaluateFourierSeries = result
End Function
' Параметрическое восстановление кривой
Public Sub EvaluateParametricFourier(ByVal t As Double, _
coeffX As FourierCoefficients, _
coeffY As FourierCoefficients, _
ByVal n As Long, _
ByRef x_out As Double, _
ByRef y_out As Double)
x_out = EvaluateFourierSeries(t, coeffX, n)
y_out = EvaluateFourierSeries(t, coeffY, n)
End Sub
```
### **2. Минимальная реализация с замыканием на Excel**
```vba
' Module: modFourierSimple
Option Explicit
' Простейшая функция: принимает два диапазона (x и y) и возвращает аппроксимацию
Public Function FourierApproximation(rngX As Range, rngY As Range, _
Optional harmonics As Long = 10, _
Optional t As Double = 0) As Variant
Dim xData() As Variant, yData() As Variant
Dim coeffX As FourierCoefficients, coeffY As FourierCoefficients
Dim x_out As Double, y_out As Double
' Загружаем данные из диапазонов
xData = rngX.Value
yData = rngY.Value
' Проверяем размерность
If UBound(xData, 1) <> UBound(yData, 1) Then
FourierApproximation = CVErr(xlErrValue)
Exit Function
End If
' Вычисляем коэффициенты
ComputeFourierCoefficientsSimple xData, yData, harmonics, coeffX, coeffY
' Вычисляем значение в точке t
EvaluateParametricFourier t, coeffX, coeffY, harmonics, x_out, y_out
' Возвращаем массив из двух значений
FourierApproximation = Array(x_out, y_out)
End Function
' Упрощенная версия вычисления коэффициентов
Private Sub ComputeFourierCoefficientsSimple(xData As Variant, yData As Variant, _
ByVal n As Long, _
ByRef coeffX As FourierCoefficients, _
ByRef coeffY As FourierCoefficients)
Dim Npoints As Long
Npoints = UBound(xData, 1)
' Инициализация
coeffX.a0 = 0
coeffY.a0 = 0
ReDim coeffX.a(1 To n)
ReDim coeffX.b(1 To n)
ReDim coeffY.a(1 To n)
ReDim coeffY.b(1 To n)
Dim i As Long, k As Long
Dim t As Double, cos_kt As Double, sin_kt As Double
' a0
For i = 1 To Npoints
coeffX.a0 = coeffX.a0 + xData(i, 1)
coeffY.a0 = coeffY.a0 + yData(i, 1)
Next i
coeffX.a0 = coeffX.a0 / Npoints
coeffY.a0 = coeffY.a0 / Npoints
' an, bn
For k = 1 To n
For i = 1 To Npoints
t = 2 * Application.WorksheetFunction.Pi() * (i - 1) / Npoints
cos_kt = Cos(k * t)
sin_kt = Sin(k * t)
coeffX.a(k) = coeffX.a(k) + xData(i, 1) * cos_kt
coeffX.b(k) = coeffX.b(k) + xData(i, 1) * sin_kt
coeffY.a(k) = coeffY.a(k) + yData(i, 1) * cos_kt
coeffY.b(k) = coeffY.b(k) + yData(i, 1) * sin_kt
Next i
coeffX.a(k) = 2 * coeffX.a(k) / Npoints
coeffX.b(k) = 2 * coeffX.b(k) / Npoints
coeffY.a(k) = 2 * coeffY.a(k) / Npoints
coeffY.b(k) = 2 * coeffY.b(b) / Npoints
Next k
End Sub
```
### **3. Готовый рабочий пример для Excel**
```vba
' Module: modFourierExample
Option Explicit
' Пример использования: аппроксимация окружности
Public Sub TestFourierCircle()
Dim i As Long, N As Long
N = 100
' Создаем данные для окружности
Dim x() As Double, y() As Double
ReDim x(1 To N)
ReDim y(1 To N)
Dim t As Double
For i = 1 To N
t = 2 * Application.WorksheetFunction.Pi() * (i - 1) / N
x(i) = Cos(t)
y(i) = Sin(t)
Next i
' Вычисляем коэффициенты Фурье
Dim coeffX As FourierCoefficients, coeffY As FourierCoefficients
Dim harmonics As Long: harmonics = 5
ComputeFourierCoefficients x, y, harmonics, coeffX, coeffY
' Восстанавливаем кривую
Dim ws As Worksheet
Set ws = ThisWorkbook.Worksheets.Add
ws.Range("A1").Value = "t"
ws.Range("B1").Value = "Исходный X"
ws.Range("C1").Value = "Исходный Y"
ws.Range("D1").Value = "Фурье X"
ws.Range("E1").Value = "Фурье Y"
Dim t_val As Double, x_fourier As Double, y_fourier As Double
For i = 1 To 360
t_val = 2 * Application.WorksheetFunction.Pi() * (i - 1) / 360
' Оригинальная функция (окружность)
Dim x_orig As Double, y_orig As Double
x_orig = Cos(t_val)
y_orig = Sin(t_val)
' Аппроксимация Фурье
EvaluateParametricFourier t_val, coeffX, coeffY, harmonics, x_fourier, y_fourier
ws.Cells(i + 1, 1).Value = t_val
ws.Cells(i + 1, 2).Value = x_orig
ws.Cells(i + 1, 3).Value = y_orig
ws.Cells(i + 1, 4).Value = x_fourier
ws.Cells(i + 1, 5).Value = y_fourier
Next i
' Строим график
Dim ch As Chart
Set ch = ws.Shapes.AddChart2(240, xlXYScatterLinesNoMarkers).Chart
With ch
.SetSourceData Source:=ws.Range("B2:C361")
.SeriesCollection.NewSeries
.SeriesCollection(2).Values = ws.Range("D2:D361")
.SeriesCollection(2).XValues = ws.Range("E2:E361")
.SeriesCollection(1).Name = "Исходная окружность"
.SeriesCollection(2).Name = "Аппроксимация Фурье"
End With
MsgBox "Аппроксимация завершена!", vbInformation
End Sub
' Быстрая функция для использования в ячейках Excel
Public Function FOURIER_X(rngX As Range, rngY As Range, _
t As Double, Optional n As Long = 10) As Double
Dim result As Variant
result = FourierApproximation(rngX, rngY, n, t)
If IsArray(result) Then
FOURIER_X = result(0)
Else
FOURIER_X = CVErr(xlErrValue)
End If
End Function
Public Function FOURIER_Y(rngX As Range, rngY As Range, _
t As Double, Optional n As Long = 10) As Double
Dim result As Variant
result = FourierApproximation(rngX, rngY, n, t)
If IsArray(result) Then
FOURIER_Y = result(1)
Else
FOURIER_Y = CVErr(xlErrValue)
End If
End Function
```
### **4. Ультра-простая версия "без лишней фигни"**
```vba
' Module: modFourierMinimal
Option Explicit
' Минимальный ряд Фурье - только самое необходимое
Public Sub SimpleFourierFit(inputX As Range, inputY As Range, _
outputX As Range, outputY As Range, _
Optional harmonics As Long = 20)
Dim xData As Variant, yData As Variant
xData = inputX.Value
yData = inputY.Value
Dim N As Long, M As Long
N = UBound(xData, 1)
M = harmonics
' Вычисляем коэффициенты напрямую
Dim a0_x As Double, a0_y As Double
Dim a_x() As Double, b_x() As Double
Dim a_y() As Double, b_y() As Double
ReDim a_x(1 To M)
ReDim b_x(1 To M)
ReDim a_y(1 To M)
ReDim b_y(1 To M)
' a0
Dim i As Long, k As Long
For i = 1 To N
a0_x = a0_x + xData(i, 1)
a0_y = a0_y + yData(i, 1)
Next i
a0_x = a0_x / N
a0_y = a0_y / N
' an, bn
Dim t As Double, cosVal As Double, sinVal As Double
For k = 1 To M
For i = 1 To N
t = 6.28318530717959 * (i - 1) / N ' 2π
cosVal = Cos(k * t)
sinVal = Sin(k * t)
a_x(k) = a_x(k) + xData(i, 1) * cosVal
b_x(k) = b_x(k) + xData(i, 1) * sinVal
a_y(k) = a_y(k) + yData(i, 1) * cosVal
b_y(k) = b_y(k) + yData(i, 1) * sinVal
Next i
a_x(k) = 2 * a_x(k) / N
b_x(k) = 2 * b_x(k) / N
a_y(k) = 2 * a_y(k) / N
b_y(k) = 2 * b_y(k) / N
Next k
' Восстанавливаем кривую
Dim outRows As Long
outRows = outputX.Rows.Count
Dim x_out As Double, y_out As Double
Dim j As Long
For j = 1 To outRows
t = 6.28318530717959 * (j - 1) / outRows
x_out = a0_x / 2
y_out = a0_y / 2
For k = 1 To M
x_out = x_out + a_x(k) * Cos(k * t) + b_x(k) * Sin(k * t)
y_out = y_out + a_y(k) * Cos(k * t) + b_y(k) * Sin(k * t)
Next k
outputX.Cells(j, 1).Value = x_out
outputY.Cells(j, 1).Value = y_out
Next j
End Sub
```
### **5. Готовые формулы для использования в Excel**
Вставьте эти UDF (User Defined Functions) для использования напрямую в ячейках:
```vba
' UDF функции для Excel
Public Function FOUPARAM_X(x_range As Range, y_range As Range, _
t As Double, Optional n_harmonics As Long = 15) As Double
Dim x_data As Variant, y_data As Variant
x_data = x_range.Value
y_data = y_range.Value
Dim N As Long
N = UBound(x_data, 1)
' Вычисляем a0_x
Dim a0_x As Double
Dim i As Long
For i = 1 To N
a0_x = a0_x + x_data(i, 1)
Next i
a0_x = a0_x / N
' Вычисляем an_x, bn_x
Dim result As Double
result = a0_x / 2
Dim k As Long
Dim t_param As Double, cos_kt As Double, sin_kt As Double
For k = 1 To n_harmonics
Dim an_x As Double, bn_x As Double
an_x = 0
bn_x = 0
For i = 1 To N
t_param = 2 * Application.WorksheetFunction.Pi() * (i - 1) / N
cos_kt = Cos(k * t_param)
sin_kt = Sin(k * t_param)
an_x = an_x + x_data(i, 1) * cos_kt
bn_x = bn_x + x_data(i, 1) * sin_kt
Next i
an_x = 2 * an_x / N
bn_x = 2 * bn_x / N
result = result + an_x * Cos(k * t) + bn_x * Sin(k * t)
Next k
FOUPARAM_X = result
End Function
Public Function FOUPARAM_Y(x_range As Range, y_range As Range, _
t As Double, Optional n_harmonics As Long = 15) As Double
Dim x_data As Variant, y_data As Variant
x_data = x_range.Value
y_data = y_range.Value
Dim N As Long
N = UBound(y_data, 1)
' Вычисляем a0_y
Dim a0_y As Double
Dim i As Long
For i = 1 To N
a0_y = a0_y + y_data(i, 1)
Next i
a0_y = a0_y / N
' Вычисляем an_y, bn_y
Dim result As Double
result = a0_y / 2
Dim k As Long
Dim t_param As Double, cos_kt As Double, sin_kt As Double
For k = 1 To n_harmonics
Dim an_y As Double, bn_y As Double
an_y = 0
bn_y = 0
For i = 1 To N
t_param = 2 * Application.WorksheetFunction.Pi() * (i - 1) / N
cos_kt = Cos(k * t_param)
sin_kt = Sin(k * t_param)
an_y = an_y + y_data(i, 1) * cos_kt
bn_y = bn_y + y_data(i, 1) * sin_kt
Next i
an_y = 2 * an_y / N
bn_y = 2 * bn_y / N
result = result + an_y * Cos(k * t) + bn_y * Sin(k * t)
Next k
FOUPARAM_Y = result
End Function
```
### **6. Как использовать в Excel:**
1. **В ячейках Excel:**
```
=X: =FOUPARAM_X($A$2:$A$100, $B$2:$B$100, C2, 20)
=Y: =FOUPARAM_Y($A$2:$A$100, $B$2:$B$100, C2, 20)
```
Где:
- `$A$2:$A$100` - исходные X координаты
- `$B$2:$B$100` - исходные Y координаты
- `C2` - значение параметра t (от 0 до 2π)
- `20` - количество гармоник (опционально)
2. **Из VBA:**
```vba
' Просто вызовите
Call SimpleFourierFit(Range("A2:A100"), Range("B2:B100"), _
Range("D2:D361"), Range("E2:E361"), 25)
```
### **Ключевые особенности этого решения:**
1. **Без дифференцирования** - используем только суммы и тригонометрические функции
2. **Без лишней фигни** - минимальный код, только суть
3. **Параметрический вид** - отдельные ряды для x(t) и y(t)
4. **Работает напрямую с данными Excel**
5. **Не требует дополнительных библиотек**
### **Что делает этот код:**
1. **Берет ваши исходные точки (x, y)**
2. **Вычисляет коэффициенты Фурье** для x и y отдельно
3. **Восстанавливает кривую** по формуле:
```
x(t) = a0_x/2 + Σ[an_x·cos(nt) + bn_x·sin(nt)]
y(t) = a0_y/2 + Σ[an_y·cos(nt) + bn_y·sin(nt)]
```
4. **t ∈ [0, 2π]** - параметр, пробегающий полный период
Это **классический тригонометрический ряд Фурье в параметрической форме**, без производных, интегралов (используем дискретные суммы) и сложных математических конструкций. |
