imin = 1

jmin = 2

min = 1000

For i = 1 To n

For j = 1 To n

If Application.Cells(26 + j, i + 1) < min Then

If i <> j Then

If (k(i) = 2) And (k(j) = 1) Then

imin = i

jmin = j

min = Application.Cells(26 + j, i + 1)

End If

End If

End If

Next j

Next i

k(jmin) = 2

Application.Cells(180 + l, 7) = jmin

Next l

'Вывод классов по признаку четность на рабочий лист

l = 1

For i = 1 To n

If k(i) = 1 Then

Application.Cells(176 + l, 13) = i

Application.Cells(176 + l, 15) = Application.Cells(1 + i, 1)

Application.Cells(176 + l, 16) = Application.Cells(1 + i, 2)

Application.Cells(176 + l, 17) = Application.Cells(1 + i, 3)

l = l + 1

End If

Next i

m = 1

For i = 1 To n

If k(i) = 2 Then

Application.Cells(176 + m, 14) = i

Application.Cells(186 + m, 15) = Application.Cells(1 + i, 1)

Application.Cells(186 + m, 16) = Application.Cells(1 + i, 2)

Application.Cells(186 + m, 17) = Application.Cells(1 + i, 3)

m = m + 1

End If

Next i

Cells(19, 4) = "Готово"

GoTo metka

End If

metka:

End Sub

Private Sub CommandButton3_Click()

'Очистка ячеек

Cells(19, 4) = "Ждите..."

Cells(4, 4) = ""

Cells(4, 5) = ""

Cells(4, 6) = ""

Cells(7, 4) = ""

Cells(7, 5) = ""

Cells(7, 6) = ""

For i = 2 To 20 + 2

Cells(i, 1) = ""

Cells(i, 2) = ""

Cells(i, 3) = ""

Next i

For i = 2 To 20 + 2

Cells(i + 1, 7) = ""

Cells(i + 1, 8) = ""

Cells(i + 1, 9) = ""

Next i

For i = 2 To 20 + 2

Cells(i + 1, 10) = ""

Cells(i + 1, 11) = ""

Cells(i + 1, 12) = ""

Next i

For i = 1 To 20

For j = 1 To 20

Cells(i + 2, j + 18) = ""

Next j

Next i

For i = 1 To 20

For j = 1 To 20

Cells(i + 24, j + 18) = ""

Next j

Next i

For i = 1 To 20 / 2

Cells(26 + i, 1) = ""

Cells(26 + i, 2) = ""

Cells(40 + i, 1) = ""

Cells(40 + i, 2) = ""

Cells(54 + i, 1) = ""

Cells(54 + i, 2) = ""

Cells(68 + i, 1) = ""

Cells(68 + i, 2) = ""

Cells(25 + i, 7) = ""

Cells(39 + i, 7) = ""

Cells(53 + i, 7) = ""

Cells(68 + i, 7) = ""

Next i

For i = 1 To 10

Cells(26 + i, 1) = ""

Cells(26 + i, 2) = ""

Cells(26 + i, 13) = ""

Cells(26 + i, 14) = ""

Cells(76 + i, 1) = ""

Cells(76 + i, 2) = ""

Cells(76 + i, 13) = ""

Cells(76 + i, 14) = ""

Cells(126 + i, 1) = ""

Cells(126 + i, 2) = ""

Cells(126 + i, 13) = ""

Cells(126 + i, 14) = ""

Cells(176 + i, 1) = ""

Cells(176 + i, 2) = ""

Cells(176 + i, 13) = ""

Cells(176 + i, 14) = ""

Cells(25 + i, 7) = ""

Cells(75 + i, 7) = ""

Cells(125 + i, 7) = ""

Cells(175 + i, 7) = ""

Next i

For i = 1 To 20

Cells(26 + i, 3) = ""

Cells(26 + i, 4) = ""

Cells(26 + i, 5) = ""

Cells(76 + i, 3) = ""

Cells(76 + i, 4) = ""

Cells(76 + i, 5) = ""

Cells(126 + i, 3) = ""

Cells(126 + i, 4) = ""

Cells(126 + i, 5) = ""

Cells(176 + i, 3) = ""

Cells(176 + i, 4) = ""

Cells(176 + i, 5) = ""

Cells(26 + i, 15) = ""

Cells(26 + i, 16) = ""

Cells(26 + i, 17) = ""

Cells(76 + i, 15) = ""

Cells(76 + i, 16) = ""

Cells(76 + i, 17) = ""

Cells(126 + i, 15) = ""

Cells(126 + i, 16) = ""

Cells(126 + i, 17) = ""

Cells(176 + i, 15) = ""

Cells(176 + i, 16) = ""

Cells(176 + i, 17) = ""

Cells(19, 4) = "Готово."

End Sub

Private Sub CommandButton4_Click()

UserForm1.Hide

End Sub

Private Sub CommandButton5_Click()

'генерация элементов выборки 2

m = InputBox("Введите количество элементов второй подвыборки", "Ввод")

If m > 20 Then

MsgBox "Количество элементов более 20 не обрабатывается!", 48, "Ошибка!"

GoTo metka

End If

Cells(19, 4) = "Ждите..."

For i = 1 To m

Randomize

Cells(i + 11, 1) = RndN(2, 1)

Next i

For i = 1 To m

Randomize

Cells(i + 11, 2) = RndN(2, 1)

Next i

For i = 1 To m

Randomize

Cells(i + 11, 3) = RndN(2, 1)

Next i

Cells(19, 4) = "Готово."

metka:

End Sub

Приложение Г

Текст программы макроса для непараметрических методов статистического описания выборки

Dim task As Integer

Private Sub CommandButton1_Click()

Dim n As Integer, k As Integer, i As Integer, j As Integer, _

c() As Double, t As Double

For i = 18 To 500

For j = 3 To 7

Cells(i, j) = ""

Next j

Next i

If Cells(16, 3) = "" Then

Cells(17, 5) = "Введите объем выборки в ячейку C8"

End If

If Cells(17, 3) = "" Then

Cells(17, 5) = "Введите число интервалов в ячейку C9"

End If

n = Cells(16, 3)

k = Cells(17, 3)

ReDim c(n)

For i = 1 To n

c(i) = Cells(18 + i, 1)

Next i

For i = 1 To n - 1

For j = 1 To n - i

If c(j) > c(j + 1) Then

t = c(j)

c(j) = c(j + 1)

c(j + 1) = t

End If

Next j

Next i

Select Case task

Case 1: f = EIGistPol(k, n, c)

Case 2: f = EFGist(k, n, c)

If f = -1 Then

Cells(23, 4) = "Невозможно построить равнона-"

Cells(24, 4) = "полненную гистограмму"

End If

Case 3: f = NuclAppr(k, n, c)

End Select

End Sub

Private Sub OptionButton1_Click()

task = 1

End Sub

Private Sub OptionButton2_Click()

task = 2

End Sub

Private Sub OptionButton3_Click()

task = 3

End Sub

Function EIGistPol(k As Integer, n As Integer, c() As Double) As Integer

Dim i As Integer, j As Integer, m As Integer, _

h As Double, f() As Double

h = (c(n) - c(1)) / k

ReDim f(k)

Cells(18, 3) = "EIGdeltk"

Cells(19, 3) = c(1)

Cells(18, 6) = "EIGist"

For i = 1 To k

m = 0

For j = 1 To n

If c(j) >= c(1) + (i - 1) * h And c(j) <= c(1) + i * h Then m = m + 1

Next j

f(i) = m / (n * h)

Cells(19 + i, 3) = c(1) + i * h

Cells(18 + i, 6) = f(i)

Next i

Cells(18, 4) = "EIPdeltk"

Cells(19, 4) = c(1) - h / 2

Cells(19, 7) = 0

Cells(18, 7) = "EIPol"

For i = 1 To k

Cells(19 + i, 4) = c(1) + i * h - h / 2

Cells(19 + i, 7) = f(i)

Next i

Cells(20 + k, 4) = c(n) + h / 2

Cells(20 + k, 7) = 0

EIGistPol = 1

End Function

Function EFGist(k As Integer, n As Integer, c() As Double) As Integer

Dim i As Integer, j As Integer, s As Integer, m As Integer, _

f() As Double, p() As Double

ReDim f(k)

If n Mod k = 0 Then

m = n / k

Else

Cells(20, 4) = "Множество значений выборки "

Cells(21, 4) = "нельзя разбить на указанное "

Cells(22, 4) = "число равнонаполненных интервалов"

EFGist = -1

Exit Function

End If

If c(1) = c(n) Then

Cells(20, 4) = "Построить равнонаполненные гистограмму"

Cells(20, 4) = " и полигон частот по данной выборке "

Cells(20, 4) = "нельзя, так как выборка однородна"

End If

ReDim p(k, 3)

s = 0

For i = 0 To k - 1

For j = 0 To n - i * m + s - 1

If c((i + 1) * m) <> c(i * m - s + 1) Then

p(i + 1, 1) = c(i * m - s + 1)

p(i + 1, 2) = c((i + 1) * m + j) - c(i * m - s + 1)

p(i + 1, 3) = (m + j + s) / (n * k * p(i + 1, 2))

s = -j

GoTo ni

Else

j = j + 1

End If

Next j

ni: Next i

Cells(18, 4) = "EPxGist"

Cells(18, 5) = "EPhGist"

Cells(18, 6) = "EPxPol"

Cells(18, 7) = "EPhPol"

s = 0

For i = 1 To k

Cells(18 + 4 * i - 3, 4) = p(i, 1)

Cells(18 + 4 * i - 2, 4) = p(i, 1)

Cells(18 + 4 * i - 1, 4) = p(i, 1) + p(i, 2)

Cells(18 + 4 * i, 4) = p(i, 1) + p(i, 2)

Cells(18 + 4 * i - 3, 5) = 0

Cells(18 + 4 * i - 2, 5) = p(i, 3)

Cells(18 + 4 * i - 1, 5) = p(i, 3)

Cells(18 + 4 * i, 5) = 0

Cells(18 + i, 6) = p(i, 1) + p(i, 2) / 2

Cells(18 + i, 7) = p(i, 3)

Next i

EFGist = 1

End Function

Function NuclAppr(k As Integer, n As Integer, c() As Double) As Integer

Dim i As Integer, j As Integer, _

f As Double, x() As Double, _

d As Double, cof As Double

ReDim x(n, 2)

d = (c(n) - c(1)) / k

Cells(18, 5) = "x"

Cells(18, 7) = "NAp"

For i = 1 To n

x(i, 1) = c(i) - d / 2

x(i, 2) = c(i) + d / 2

Cells(18 + 2 * i - 1, 5) = x(i, 1)

Cells(18 + 2 * i, 5) = x(i, 2)

Next i

For i = 1 To n

cof = (k - 1) / (n + 1) / (c(n) - c(1)) / k

f = 0

For j = 1 To n

If c(j) >= x(i, 1) And c(j) <= x(i, 2) Then f = f + 1

Next j

f = cof + n / (n + 1) * f / d

Cells(18 + i, 7) = f

Next i

NuclAppr = 1

End Function

Страницы: 1, 2, 3, 4, 5, 6, 7, 8