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

 

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