Тексты макросов Текст макроса для кластерного анализа

Option Explicit

Const n = 14 ' Количество объектов

Dim x(n) As Double ' Массивы координат (параметров)

Dim y(n) As Double ' объектов

Dim s(n, n) As Double ' Матрица расстояний между объектами

Dim Chain(3, n - 1) As Double 'Массив параметров цепочки расстояний

' 1-ый параметр - расстояние

' 2-ой параметр – номер первого объекта

' 3-ий параметр – номер второго объекта

Dim Checked(n) As Boolean ' Массив выбранных объектов

Dim i, j, k As Integer '

Dim Imin As Integer '

Dim Jmin As Integer '

Dim MinS As Double '

Dim Xmin As Double ' Переменные,

Dim Xmax As Double ' необходимые

Dim Ymin As Double ' для нормирования

Dim Ymax As Double ' данных

Private Sub CommandButton1_Click()

' Считывание данных

For i = 1 To n: x(i) = Cells(i + 5, 3): Next

For i = 1 To n: y(i) = Cells(i + 5, 4): Next

'

' Нормирование данных

'

' Определение границ параметров объектов

Xmin = 1E+38: Xmax = -1E+38

Ymin = 1E+38: Ymax = -1E+38

For i = 1 To n

If x(i) < Xmin Then Xmin = x(i)

If x(i) > Xmax Then Xmax = x(i)

If y(i) < Ymin Then Ymin = x(i)

If y(i) > Ymax Then Ymax = x(i)

Next

' Пересчет в нормированные значения (на диапазон 0..100)

For i = 1 To n

x(i) = 100 * (x(i) - Xmin) / (Xmax - Xmin)

y(i) = 100 * (y(i) - Ymin) / (Ymax - Ymin)

Next

' Расчет матрицы расстояний между объектами

For i = 1 To n

For j = 1 To n

s(i, j) = Sqr((x(i) - x(j)) ^ 2 + (y(i) - y(j)) ^ 2)

Next

Next

For i = 1 To n: Checked(i) = False: Next

' Нахождение первой пары наиболее близких объектов

k = 1

MinS = 1E+38

For i = 1 To n - 1

For j = 2 To n

If s(i, j) < MinS And i <> j Then

MinS = s(i, j): Imin = i: Jmin = j

End If

Next

Next

'Цикл расчета массива цепочки расстояний

k = 1

While k < n - 1

k = k + 1

MinS = 1E+38

For i = 1 To n - 1

For j = 2 To n

If (s(i, j) < MinS) And (i <> j) And _

(Checked(i) And Not Checked(j) Or _

Not Checked(i) And Checked(j)) Then

MinS = s(i, j): Imin = i: Jmin = j

End If

Next

Next

' Параметры очередной пары наиболее близких объектов

Chain(1, k) = MinS

Chain(2, k) = Imin

Chain(3, k) = Jmin

Checked(Imin) = True: Checked(Jmin) = True

Wend

'Вывод цепочки расстояний на экран

For i = 1 To n - 1

Cells(i + 10, 6) = Chain(1, i)

Cells(i + 10, 7) = Chain(2, i)

Cells(i + 10, 8) = Chain(3, i)

Next

End Sub

Текст макроса для решения систем дифференциальных уравнений

Option Explicit

Dim N(3) As Double

Dim F(3) As Double

Dim k1, k2, k3, k4, k5, k6 As Double

Dim T, tt, dt As Double

Dim i, k, h, nPeriod As Integer

Sub Systema()

F(1) = k1 * N(1) - k2 * N(1) * N(2)

F(2) = -k3 * N(2) + k4 * N(1) * N(2)

F(3) = 0

End Sub

Private Sub CommandButton1_Click()

For i = 1 To 3: N(i) = Cells(7 + i, 2): Next

k1 = Cells(16, 2): k2 = Cells(17, 2)

k3 = Cells(18, 2): k4 = Cells(19, 2)

k5 = Cells(20, 2): k6 = Cells(21, 2)

T = Cells(12, 2)

dt = Cells(13, 2)

nPeriod = Int(T / 50 / dt)

k = 8

Cells(k, 4) = 0

For i = 1 To 3: Cells(k, 4 + i) = N(i): Next

tt = 0: h = 0

While tt < T

h = h + 1

tt = tt + dt

Call Systema

For i = 1 To 3: N(i) = N(i) + F(i) * dt: Next

If h = nPeriod Then

k = k + 1

Cells(k, 4) = tt

For i = 1 To 3: Cells(k, 4 + i) = N(i): Next

h = 0

End If

Wend

End Sub