1.                Беляев С.П. Курс лекций по «Исследованию операций».

2.                Кузменко В.Г, Программирование на Microsoft Visual Basic for Applications 2003 /Москва изд. Бином; 2004г. – 880 с.: ил.


Листинг программы

 

Форма About (справка о программе)

Private Sub UserForm_Terminate()

Hide

InsForm.Show

End Sub

Форма HelpForm1 (помощь в заполнении таблицы)

 

Private Sub CommandButton1_Click()

Hide

OKForm.StartUpPosition = 0

OKForm.Top = 450

OKForm.Left = 580

OKForm.Show

End Sub

Private Sub CommandButton2_Click()

Hide

InsForm.Show

End Sub

Private Sub UserForm_Terminate()

Hide

InsForm.Show

End Sub

Форма HelpForm2 (помощь в понимании результатов вычислений)

 

Private Sub CommandButton1_Click()

check = True

Hide

SolForm.StartUpPosition = 0

SolForm.Top = 350

SolForm.Left = 480

SolForm.Show

End Sub

Private Sub CommandButton2_Click()

check = False

Hide

SolForm.StartUpPosition = 0

SolForm.Top = 350

SolForm.Left = 480

SolForm.Show

End Sub

Форма HelpForm3 (помощь в переводе единиц времени)

Private Sub CommandButton1_Click()

check = True

Hide

SolForm.StartUpPosition = 0

SolForm.Top = 350

SolForm.Left = 480

SolForm.Show

End Sub

Private Sub CommandButton2_Click()

check = False

Hide

SolForm.StartUpPosition = 0

SolForm.Top = 350

SolForm.Left = 480

SolForm.Show

End Sub

Форма InsForm (ввод количества этапов работ, проверка формата листа, проверка правильности ввода, вызов справки, выход из программы, переход к расчётной форме)

 

'Проверка правильности ввода

Private Sub CommandButton1_Click()

Dim Answer As String

Application.ScreenUpdating = False

If iget.Value = "" Then

MsgBox "Введите количество этапов", vbCritical + vbOKOnly, "Ошибка ввода"

Exit Sub

End If

If Not (IsNumeric(iget.Value)) Then

MsgBox "Количество этапов работы должно быть числом", vbCritical + vbOKOnly, "Ошибка ввода"

Exit Sub

End If

If iget.Value < 3 Then

MsgBox "Количество этапов работы должно быть не менее 3", vbCritical + vbOKOnly, "Ошибка ввода"

Exit Sub

End If

If iget.Value > 254 Then

MsgBox "Количество этапов работы должно быть не более 222", vbCritical + vbOKOnly, "Ошибка ввода"

Exit Sub

End If

n = Fix(iget.Value)

'Проверка листа на наличие информации

For i = 1 To 254

For j = 1 To 254

If Not ActiveSheet.Cells(i, j).Value = "" Then

Answer = MsgBox("Лист содержит информацию! При продолжении она будет уничтожена! Продолжить?", vbCritical + vbOKCancel, "Предупреждение")

End If

If Answer = vbCancel Then

i = 254

j = 254

Exit Sub

End If

If Answer = vbOK Then

i = 254

j = 254

End If

Next j

Next i

'Построение таблицы ввода и переход к ней

Range("A1:IV254").Select

Selection.Clear

InsData

Application.ScreenUpdating = True

Hide

If help.Value = True Then

hlp = True

HelpForm1.Show

Else

hlp = False

OKForm.StartUpPosition = 0

OKForm.Top = 450

OKForm.Left = 580

OKForm.Show

End If

End Sub

Private Sub CommandButton2_Click()

Hide

STF.Show

End Sub

Private Sub CommandButton3_Click()

Hide

About.Show

End Sub

Public Sub Start()

iget.Value = n

End Sub

Private Sub CommandButton4_Click()

Dim flag As Boolean

Hide

SolForm.StartUpPosition = 0

SolForm.Top = 350

SolForm.Left = 480

SolForm.Show

flag = True

n = 1

If Not ActiveSheet.Cells(1, 1).Value = "№" Then

MsgBox "Лист не отформатирован для расчёта, воспользуйтесь окном ввода данных", vbCritical + vbOKOnly, "Ошибка"

Hide

InsForm.Show

Exit Sub

End If

Do While flag

n = n + 1

If ActiveSheet.Cells(n, 1).Value = "" Then

flag = False

End If

If ActiveSheet.Cells(n, 1).Value = n - 1 Then

flag = True

Else: flag = False

End If

Loop

n = n - 2

For i = 2 To n

If Not ActiveSheet.Cells(1, i).Value = i - 1 Then

MsgBox "Лист не отформатирован для расчёта, воспользуйтесь окном ввода данных", vbCritical + vbOKOnly, "Ошибка"

Hide

InsForm.Show

Exit Sub

End If

Next i

End Sub

Private Sub SpinButton1_SpinUp()

If iget.Value <= 222 Then

iget.Value = iget.Value + 1

Else

Exit Sub

End If

End Sub

Private Sub SpinButton1_SpinDown()

If iget.Value >= 4 Then

iget.Value = iget.Value - 1

Else

Exit Sub

End If

End Sub

Private Sub UserForm_Initialize()

iget.Value = 10

Sheets("Data").Select

End Sub

Private Sub UserForm_Terminate()

Hide

STF.Show

End Sub

Форма OKForm (подтверждение окончания ввода начальных данных)

Private Sub CommandButton1_Click()

SolForm.StartUpPosition = 0

SolForm.Top = 350

SolForm.Left = 480

Hide

SolForm.Show

End Sub

Private Sub UserForm_Terminate()

Hide

SolForm.StartUpPosition = 0

SolForm.Top = 350

SolForm.Left = 480

SolForm.Show

End Sub

Форма Perevod1 (запоминание текущих единиц времени)

 

'Запоминание текущих единиц времени

Private Sub CommandButton1_Click()

If Minutes.Value = True Then

edin = 1

End If

If Chas.Value = True Then

edin = 2

End If

If Sutki.Value = True Then

edin = 3

End If

If Nedeli.Value = True Then

edin = 4

End If

If Mes.Value = True Then

edin = 5

End If

If Godi.Value = True Then

edin = 6

End If

Hide

Perevod2.Show

End Sub

Private Sub UserForm_Terminate()

Hide

SolForm.StartUpPosition = 0

SolForm.Top = 350

SolForm.Left = 480

SolForm.Show

End Sub

Форма Perevod2 (перевод единиц времени, возврат к расчётной форме)

 

'Перевод единиц времени

Private Sub CommandButton1_Click()

Hide

SolForm.Show

If ActiveSheet.Cells(1, 1).Value = "№" Then

If edin = 1 Then

If Minutes.Value = True Then

Exit Sub

End If

If Chas.Value = True Then

For i = 2 To n + 1

For j = 2 To n + 1

If Not ActiveSheet.Cells(i, j).Value = "" Then

ActiveSheet.Cells(i, j).Value = ActiveSheet.Cells(i, j).Value / 60

End If

Next j

Next i

End If

If Sutki.Value = True Then

For i = 2 To n + 1

For j = 2 To n + 1

If Not ActiveSheet.Cells(i, j).Value = "" Then

ActiveSheet.Cells(i, j).Value = ActiveSheet.Cells(i, j).Value / 1440

End If

Next j

Next i

End If

If Nedeli.Value = True Then

For i = 2 To n + 1

For j = 2 To n + 1

If Not ActiveSheet.Cells(i, j).Value = "" Then

ActiveSheet.Cells(i, j).Value = ActiveSheet.Cells(i, j).Value / 10080

End If

Next j

Next i

End If

If Mes.Value = True Then

MsgBox "Точный перевод невозможен. Попробуйте другой вариант", vbCritical + vbOKOnly, "Ошибка ввода"

End If

If Godi.Value = True Then

For i = 2 To n + 1

For j = 2 To n + 1

If Not ActiveSheet.Cells(i, j).Value = "" Then

ActiveSheet.Cells(i, j).Value = ActiveSheet.Cells(i, j).Value / 525600

End If

Next j

Next i

End If

End If

If edin = 2 Then

If Minutes.Value = True Then

For i = 2 To n + 1

For j = 2 To n + 1

If Not ActiveSheet.Cells(i, j).Value = "" Then

ActiveSheet.Cells(i, j).Value = ActiveSheet.Cells(i, j).Value * 60

End If

Next j

Next i

End If

If Chas.Value = True Then

Exit Sub

End If

If Sutki.Value = True Then

For i = 2 To n + 1

For j = 2 To n + 1

If Not ActiveSheet.Cells(i, j).Value = "" Then

ActiveSheet.Cells(i, j).Value = ActiveSheet.Cells(i, j).Value / 24

End If

Next j

Next i

End If

If Nedeli.Value = True Then

For i = 2 To n + 1

For j = 2 To n + 1

If Not ActiveSheet.Cells(i, j).Value = "" Then

ActiveSheet.Cells(i, j).Value = ActiveSheet.Cells(i, j).Value / 168

End If

Next j

Next i

End If

If Mes.Value = True Then

MsgBox "Точный перевод невозможен. Попробуйте другой вариант", vbCritical + vbOKOnly, "Ошибка ввода"

End If

If Godi.Value = True Then

For i = 2 To n + 1

For j = 2 To n + 1

If Not ActiveSheet.Cells(i, j).Value = "" Then

ActiveSheet.Cells(i, j).Value = ActiveSheet.Cells(i, j).Value / 8760

End If

Next j

Next i

End If

End If

If edin = 3 Then

If Minutes.Value = True Then

For i = 2 To n + 1

For j = 2 To n + 1

If Not ActiveSheet.Cells(i, j).Value = "" Then

ActiveSheet.Cells(i, j).Value = ActiveSheet.Cells(i, j).Value * 1440

End If

Next j

Next i

End If

If Chas.Value = True Then

For i = 2 To n + 1

For j = 2 To n + 1

If Not ActiveSheet.Cells(i, j).Value = "" Then

ActiveSheet.Cells(i, j).Value = ActiveSheet.Cells(i, j).Value * 24

End If

Next j

Next i

End If

If Sutki.Value = True Then

Exit Sub

End If

If Nedeli.Value = True Then

For i = 2 To n + 1

For j = 2 To n + 1

If Not ActiveSheet.Cells(i, j).Value = "" Then

ActiveSheet.Cells(i, j).Value = ActiveSheet.Cells(i, j).Value / 7

End If

Next j

Next i

End If

If Mes.Value = True Then

MsgBox "Точный перевод невозможен. Попробуйте другой вариант", vbCritical + vbOKOnly, "Ошибка ввода"

End If

If Godi.Value = True Then

For i = 2 To n + 1

For j = 2 To n + 1

If Not ActiveSheet.Cells(i, j).Value = "" Then

ActiveSheet.Cells(i, j).Value = ActiveSheet.Cells(i, j).Value / 365

End If

Next j

Next i

End If

End If

If edin = 4 Then

If Minutes.Value = True Then

For i = 2 To n + 1

For j = 2 To n + 1

If Not ActiveSheet.Cells(i, j).Value = "" Then

ActiveSheet.Cells(i, j).Value = ActiveSheet.Cells(i, j).Value * 10080

End If

Next j

Next i

End If

If Chas.Value = True Then

For i = 2 To n + 1

For j = 2 To n + 1

If Not ActiveSheet.Cells(i, j).Value = "" Then

ActiveSheet.Cells(i, j).Value = ActiveSheet.Cells(i, j).Value * 168

End If

Next j

Next i

End If

If Sutki.Value = True Then

For i = 2 To n + 1

For j = 2 To n + 1

If Not ActiveSheet.Cells(i, j).Value = "" Then

ActiveSheet.Cells(i, j).Value = ActiveSheet.Cells(i, j).Value * 7

End If

Next j

Next i

End If

If Nedeli.Value = True Then

Exit Sub

End If

If Mes.Value = True Then

MsgBox "Точный перевод невозможен. Попробуйте другой вариант", vbCritical + vbOKOnly, "Ошибка ввода"

End If

If Godi.Value = True Then

MsgBox "Точный перевод невозможен. Попробуйте другой вариант", vbCritical + vbOKOnly, "Ошибка ввода"

End If

End If

If edin = 5 Then

If Minutes.Value = True Then

MsgBox "Точный перевод невозможен. Попробуйте другой вариант", vbCritical + vbOKOnly, "Ошибка ввода"

End If

If Chas.Value = True Then

MsgBox "Точный перевод невозможен. Попробуйте другой вариант", vbCritical + vbOKOnly, "Ошибка ввода"

End If

If Sutki.Value = True Then

MsgBox "Точный перевод невозможен. Попробуйте другой вариант", vbCritical + vbOKOnly, "Ошибка ввода"

End If

If Nedeli.Value = True Then

MsgBox "Точный перевод невозможен. Попробуйте другой вариант", vbCritical + vbOKOnly, "Ошибка ввода"

End If

If Mes.Value = True Then

Exit Sub

End If

If Godi.Value = True Then

For i = 2 To n + 1

For j = 2 To n + 1

If Not ActiveSheet.Cells(i, j).Value = "" Then

ActiveSheet.Cells(i, j).Value = ActiveSheet.Cells(i, j).Value / 12

End If

Next j

Next i

End If

End If

If edin = 6 Then

If Minutes.Value = True Then

For i = 2 To n + 1

For j = 2 To n + 1

If Not ActiveSheet.Cells(i, j).Value = "" Then

ActiveSheet.Cells(i, j).Value = ActiveSheet.Cells(i, j).Value * 525600

End If

Next j

Next i

End If

If Chas.Value = True Then

For i = 2 To n + 1

For j = 2 To n + 1

If Not ActiveSheet.Cells(i, j).Value = "" Then

ActiveSheet.Cells(i, j).Value = ActiveSheet.Cells(i, j).Value * 8760

End If

Next j

Next i

End If

If Sutki.Value = True Then

For i = 2 To n + 1

For j = 2 To n + 1

If Not ActiveSheet.Cells(i, j).Value = "" Then

ActiveSheet.Cells(i, j).Value = ActiveSheet.Cells(i, j).Value * 365

End If

Next j

Next i

End If

If Nedeli.Value = True Then

MsgBox "Точный перевод невозможен. Попробуйте другой вариант", vbCritical + vbOKOnly, "Ошибка ввода"

End If

If Mes.Value = True Then

For i = 2 To n + 1

For j = 2 To n + 1

If Not ActiveSheet.Cells(i, j).Value = "" Then

ActiveSheet.Cells(i, j).Value = ActiveSheet.Cells(i, j).Value * 12

End If

Next j

Next i

End If

If Godi.Value = True Then

Exit Sub

End If

End If

End If

If ActiveSheet.Cells(1, 1).Value = "Начальный этап" Then

If edin = 1 Then

If Minutes.Value = True Then

Exit Sub

End If

If Chas.Value = True Then

For i = 2 To scount

For j = 3 To 8

ActiveSheet.Cells(i, j).Value = ActiveSheet.Cells(i, j).Value / 60

Next j

Next i

End If

If Sutki.Value = True Then

For i = 2 To scount

For j = 3 To 8

If Not ActiveSheet.Cells(i, j).Value = "" Then

ActiveSheet.Cells(i, j).Value = ActiveSheet.Cells(i, j).Value / 1440

End If

Next j

Next i

End If

If Nedeli.Value = True Then

For i = 2 To scount

For j = 3 To 8

ActiveSheet.Cells(i, j).Value = ActiveSheet.Cells(i, j).Value / 10080

Next j

Next i

End If

If Mes.Value = True Then

MsgBox "Точный перевод невозможен. Попробуйте другой вариант", vbCritical + vbOKOnly, "Ошибка ввода"

End If

If Godi.Value = True Then

For i = 2 To scount

For j = 3 To 8

ActiveSheet.Cells(i, j).Value = ActiveSheet.Cells(i, j).Value / 525600

Next j

Next i

End If

End If

If edin = 2 Then

If Minutes.Value = True Then

For i = 2 To scount

For j = 3 To 8

ActiveSheet.Cells(i, j).Value = ActiveSheet.Cells(i, j).Value * 60

Next j

Next i

End If

If Chas.Value = True Then

Exit Sub

End If

If Sutki.Value = True Then

For i = 2 To scount

For j = 3 To 8

ActiveSheet.Cells(i, j).Value = ActiveSheet.Cells(i, j).Value / 24

Next j

Next i

End If

If Nedeli.Value = True Then

For i = 2 To scount

For j = 3 To 8

ActiveSheet.Cells(i, j).Value = ActiveSheet.Cells(i, j).Value / 168

Next j

Next i

End If

If Mes.Value = True Then

MsgBox "Точный перевод невозможен. Попробуйте другой вариант", vbCritical + vbOKOnly, "Ошибка ввода"

End If

If Godi.Value = True Then

For i = 2 To scount

For j = 3 To 8

ActiveSheet.Cells(i, j).Value = ActiveSheet.Cells(i, j).Value / 8760

Next j

Next i

End If

End If

If edin = 3 Then

If Minutes.Value = True Then

For i = 2 To scount

For j = 3 To 8

ActiveSheet.Cells(i, j).Value = ActiveSheet.Cells(i, j).Value * 1440

Next j

Next i

End If

If Chas.Value = True Then

For i = 2 To scount

For j = 3 To 8

ActiveSheet.Cells(i, j).Value = ActiveSheet.Cells(i, j).Value * 24

Next j

Next i

End If

If Sutki.Value = True Then

Exit Sub

End If

If Nedeli.Value = True Then

For i = 2 To scount

For j = 3 To 8

ActiveSheet.Cells(i, j).Value = ActiveSheet.Cells(i, j).Value / 7

Next j

Next i

End If

If Mes.Value = True Then

MsgBox "Точный перевод невозможен. Попробуйте другой вариант", vbCritical + vbOKOnly, "Ошибка ввода"

End If

If Godi.Value = True Then

For i = 2 To scount

For j = 3 To 8

ActiveSheet.Cells(i, j).Value = ActiveSheet.Cells(i, j).Value / 365

Next j

Next i

End If

End If

If edin = 4 Then

If Minutes.Value = True Then

For i = 2 To scount

For j = 3 To 8

ActiveSheet.Cells(i, j).Value = ActiveSheet.Cells(i, j).Value * 10080

Next j

Next i

End If

If Chas.Value = True Then

For i = 2 To scount

For j = 3 To 8

ActiveSheet.Cells(i, j).Value = ActiveSheet.Cells(i, j).Value * 168

Next j

Next i

End If

If Sutki.Value = True Then

For i = 2 To scount

For j = 3 To 8

ActiveSheet.Cells(i, j).Value = ActiveSheet.Cells(i, j).Value * 7

Next j

Next i

End If

If Nedeli.Value = True Then

Exit Sub

End If

If Mes.Value = True Then

MsgBox "Точный перевод невозможен. Попробуйте другой вариант", vbCritical + vbOKOnly, "Ошибка ввода"

End If

If Godi.Value = True Then

MsgBox "Точный перевод невозможен. Попробуйте другой вариант", vbCritical + vbOKOnly, "Ошибка ввода"

End If

End If

If edin = 5 Then

If Minutes.Value = True Then

MsgBox "Точный перевод невозможен. Попробуйте другой вариант", vbCritical + vbOKOnly, "Ошибка ввода"

End If

If Chas.Value = True Then

MsgBox "Точный перевод невозможен. Попробуйте другой вариант", vbCritical + vbOKOnly, "Ошибка ввода"

End If

If Sutki.Value = True Then

MsgBox "Точный перевод невозможен. Попробуйте другой вариант", vbCritical + vbOKOnly, "Ошибка ввода"

End If

If Nedeli.Value = True Then

MsgBox "Точный перевод невозможен. Попробуйте другой вариант", vbCritical + vbOKOnly, "Ошибка ввода"

End If

If Mes.Value = True Then

Exit Sub

End If

If Godi.Value = True Then

For i = 2 To scount

For j = 3 To 8

ActiveSheet.Cells(i, j).Value = ActiveSheet.Cells(i, j).Value / 12

Next j

Next i

End If

End If

If edin = 6 Then

If Minutes.Value = True Then

For i = 2 To scount

For j = 3 To 8

ActiveSheet.Cells(i, j).Value = ActiveSheet.Cells(i, j).Value * 525600

Next j

Next i

End If

If Chas.Value = True Then

For i = 2 To scount

For j = 3 To 8

ActiveSheet.Cells(i, j).Value = ActiveSheet.Cells(i, j).Value * 8760

Next j

Next i

End If

If Sutki.Value = True Then

For i = 2 To scount

For j = 3 To 8

ActiveSheet.Cells(i, j).Value = ActiveSheet.Cells(i, j).Value * 365

Next j

Next i

End If

If Nedeli.Value = True Then

MsgBox "Точный перевод невозможен. Попробуйте другой вариант", vbCritical + vbOKOnly, "Ошибка ввода"

End If

If Mes.Value = True Then

For i = 2 To scount

For j = 3 To 8

ActiveSheet.Cells(i, j).Value = ActiveSheet.Cells(i, j).Value * 12

Next j

Next i

End If

If Godi.Value = True Then

Exit Sub

End If

End If

End If

End Sub

Private Sub UserForm_Terminate()

Hide

SolForm.StartUpPosition = 0

SolForm.Top = 350

SolForm.Left = 480

SolForm.Show

End Sub

Форма SolForm (проверка правильности заполнения таблицы, проверка формата листа, проверка наличия данных в листе результатов, вызов модуля формирования и заполнения таблицы результатов)

Private Sub CommandButton1_Click()

Dim Ans As String

Dim fl As Boolean

Dim cou As Integer

cou = 0

check = True

If Not ActiveSheet.Cells(1, 1).Value = "№" Then

Ans = MsgBox("Лист не отформатирован для расчёта, воспользуйтесь окном ввода данных", vbCritical + vbOKCancel, "Ошибка")

If Ans = vbOK Then

Hide

InsForm.Show

Sheets("Data").Select

Exit Sub

End If

If Ans = vbCancel Then

Exit Sub

End If

End If

For i = 2 To n + 1

For j = 2 To n + 1

If Not IsNumeric(ActiveSheet.Cells(i, j).Value) Then

MsgBox "Длительность работы должна выражаться числом!", vbCritical + vbOKOnly, "Ошибка"

markcell

Exit Sub

End If

kn = ActiveSheet.Cells(i, j).Value

kk = Fix(ActiveSheet.Cells(i, j).Value)

If kk < kn Then

MsgBox "Дробные числа дают погрешность при вычислении! Воспользуйтесь переводом единиц времени, чтобы получить целые числа.", vbCritical + vbOKOnly, "Ошибка"

markcell

Exit Sub

End If

If Not ActiveSheet.Cells(i, j).Value = "" Then

If Not ActiveSheet.Cells(j, i).Value = "" Then

MsgBox "Есть этапы, которые замыкаются сами на себя! Это приведёт к зацикливанию программы!", vbCritical + vbOKOnly, "Ошибка"

markcell

Exit Sub

End If

End If

Next j

If Not ActiveSheet.Cells(i, i).Value = "" Then

j = i

MsgBox "Точка отсчёта не должна имееть длительности", vbCritical + vbOKOnly, "Ошибка"

markcell

Exit Sub

End If

Next i

For i = 2 To n + 1

fl = False

For j = 2 To n + 1

If Not ActiveSheet.Cells(j, i).Value = "" Then

fl = True

End If

Next j

If fl = True Then

cou = cou + 1

End If

Next i

If cou = n Then

MsgBox "Должен быть хотя бы один начальный этап!", vbCritical + vbOKOnly, "Ошибка"

Exit Sub

End If

If cou = 0 Then

MsgBox "Должен быть хотя бы один конечный этап!", vbCritical + vbOKOnly, "Ошибка"

Exit Sub

End If

If hlp = True Then

Hide

HelpForm2.Show

End If

If check = False Then

Exit Sub

End If

Application.ScreenUpdating = False

Sheets("Rez").Select

If Sheets("Rez").Cells(1, 1).Value = "Начальный этап" Then

Ans = MsgBox("Лист Rez уже содержит результаты вычислений. Сохранить вычисления в другом листе?", vbCritical + vbYesNo, "Информация")

If Ans = vbYes Then

Sheets.Add

For i = 1 To 222

For j = 1 To 8

ActiveSheet.Cells(i, j).Value = Sheets("Rez").Cells(i, j).Value

Next j

Next i

RTable

End If

End If

Sheets("Rez").Select

Range("A1:IV230").Select

Selection.Clear

RTable

Sheets("Data").Select

Solut

Application.ScreenUpdating = True

Sheets("Rez").Select

End Sub

Private Sub CommandButton2_Click()

Hide

InsForm.Start

InsForm.Show

Sheets("Data").Select

End Sub

Private Sub CommandButton6_Click()

check = True

If Not ActiveSheet.Cells(1, 1).Value = "№" Then

If Not ActiveSheet.Cells(1, 1).Value = "Начальный этап" Then

MsgBox "Лист не отформатирован для расчёта, воспользуйтесь окном ввода данных", vbCritical + vbOKOnly, "Ошибка"

Hide

InsForm.Show

Sheets("Data").Select

Exit Sub

End If

End If

If hlp = True Then

Hide

HelpForm3.Show

End If

If check = False Then

Exit Sub

End If

Hide

Perevod1.Show

End Sub

Private Sub UserForm_Terminate()

Hide

STF.Show

End Sub

Форма STF (вход в программу, завершение работы приложения)

Private Sub CommandButton1_Click()

Hide

InsForm.Show

Sheets("Data").Select

End Sub

Private Sub CommandButton2_Click()

Answer = MsgBox("Вы действительно хотите завершить работу?", vbYesNo + vbQuestion + vbDefaultButton2, "Завершение работы")

If Answer = vbYes Then

ThisWorkbook.Saved = True

Application.Quit

End If

End Sub

Private Sub UserForm_Initialize()

STF.Height = Application.Height

STF.Width = Application.Width

'STF.CommandButton1.Left = STF.Width / 4 - 36

'STF.CommandButton1.Top = STF.Top + 15

'STF.CommandButton2.Left = STF.Width / 2 - 10

'STF.CommandButton2.Top = STF.Top + 15

End Sub

Private Sub UserForm_Terminate()

Answer = MsgBox("Вы действительно хотите завершить работу?", vbYesNo + vbQuestion + vbDefaultButton2, "Завершение работы")

If Answer = vbYes Then

ThisWorkbook.Saved = True

Application.Quit

End If

End Sub

Модуль Result (построение таблицы результатов)

 

Sub RTable()

Range("A1:H1").Select

With Selection.Font

.name = "Arial Cyr"

.Size = 14

.Strikethrough = False

.Superscript = False

.Subscript = False

.OutlineFont = False

.Shadow = False

.Underline = xlUnderlineStyleNone

.ColorIndex = xlAutomatic

End With

With Selection

.HorizontalAlignment = xlCenter

.VerticalAlignment = xlBottom

.WrapText = True

.Orientation = 0

.AddIndent = False

.IndentLevel = 0

.ShrinkToFit = False

.ReadingOrder = xlContext

.MergeCells = False

End With

Range("A1").Select

ActiveCell.FormulaR1C1 = "Начальный этап"

With ActiveCell.Characters(Start:=1, Length:=14).Font

.name = "Arial Cyr"

.FontStyle = "обычный"

.Size = 14

.Strikethrough = False

.Superscript = False

.Subscript = False

.OutlineFont = False

.Shadow = False

.Underline = xlUnderlineStyleNone

.ColorIndex = xlAutomatic

End With

Range("B1").Select

Columns("A:A").ColumnWidth = 15

Range("B1").Select

ActiveCell.FormulaR1C1 = "Конечный этап"

With ActiveCell.Characters(Start:=1, Length:=13).Font

.name = "Arial Cyr"

.FontStyle = "обычный"

.Size = 14

.Strikethrough = False

.Superscript = False

.Subscript = False

.OutlineFont = False

.Shadow = False

.Underline = xlUnderlineStyleNone

.ColorIndex = xlAutomatic

End With

Range("C1").Select

Columns("B:B").ColumnWidth = 15

ActiveCell.FormulaR1C1 = "Продол- житель- ность"

With ActiveCell.Characters(Start:=1, Length:=20).Font

.name = "Arial Cyr"

.FontStyle = "обычный"

.Size = 14

.Strikethrough = False

.Superscript = False

.Subscript = False

.OutlineFont = False

.Shadow = False

.Underline = xlUnderlineStyleNone

.ColorIndex = xlAutomatic

End With

Range("D1").Select

Columns("C:C").ColumnWidth = 12

ActiveCell.FormulaR1C1 = "Время раннего начала"

With ActiveCell.Characters(Start:=1, Length:=20).Font

.name = "Arial Cyr"

.FontStyle = "обычный"

.Size = 14

.Strikethrough = False

.Superscript = False

.Subscript = False

.OutlineFont = False

.Shadow = False

.Underline = xlUnderlineStyleNone

.ColorIndex = xlAutomatic

End With

Range("E1").Select

Columns("D:D").ColumnWidth = 12

ActiveCell.FormulaR1C1 = "Время раннего конца"

With ActiveCell.Characters(Start:=1, Length:=19).Font

.name = "Arial Cyr"

.FontStyle = "обычный"

.Size = 14

.Strikethrough = False

.Superscript = False

.Subscript = False

.OutlineFont = False

.Shadow = False

.Underline = xlUnderlineStyleNone

.ColorIndex = xlAutomatic

End With

Range("F1").Select

Columns("E:E").ColumnWidth = 12

ActiveCell.FormulaR1C1 = "Время позднего начала"

With ActiveCell.Characters(Start:=1, Length:=21).Font

.name = "Arial Cyr"

.FontStyle = "обычный"

.Size = 14

.Strikethrough = False

.Superscript = False

.Subscript = False

.OutlineFont = False

.Shadow = False

.Underline = xlUnderlineStyleNone

.ColorIndex = xlAutomatic

End With

Range("G1").Select

Columns("F:F").ColumnWidth = 12

ActiveCell.FormulaR1C1 = "Время позднего конца"

With ActiveCell.Characters(Start:=1, Length:=20).Font

.name = "Arial Cyr"

.FontStyle = "обычный"

.Size = 14

.Strikethrough = False

.Superscript = False

.Subscript = False

.OutlineFont = False

.Shadow = False

.Underline = xlUnderlineStyleNone

.ColorIndex = xlAutomatic

End With

Range("H1").Select

Columns("G:G").ColumnWidth = 12

ActiveCell.FormulaR1C1 = "Полный резерв"

With ActiveCell.Characters(Start:=1, Length:=13).Font

.name = "Arial Cyr"

.FontStyle = "обычный"

.Size = 14

.Strikethrough = False

.Superscript = False

.Subscript = False

.OutlineFont = False

.Shadow = False

.Underline = xlUnderlineStyleNone

.ColorIndex = xlAutomatic

End With

Range("I1").Select

Columns("H:H").ColumnWidth = 11

Range("A2").Select

Rows("1:1").RowHeight = 55.5

End Sub

Модуль Solve (построение таблицы начальных данных, нахождение критического пути и сопутствующих данных, выделение ячейки, содержащей неверную информацию)

Public i As Integer

Public j As Integer

Public check As Boolean

Public edin As Integer

Public hlp As Boolean

Public st1 As String

Public st2 As String

Public stroka1 As String

Public stroka2 As String

Public scount As Integer

Public snum As Integer

Public n As Integer

'Модуль построения таблицы

Sub InsData()

st1 = "ABCDEFGHIJKLMNOPQRSTUVWXYZ"

h = n

If h > 26 Then

a = h \ 26

If h Mod 26 = 0 Then

stroka1 = Mid(st1, a - 1, 1)

Else

stroka1 = Mid(st1, a, 1)

End If

b = a * 26

c = h - b

If c = 0 Then c = c + 26

stroka2 = Mid(st1, c, 1)

st2 = stroka1 + stroka2

Else

st2 = Mid(st1, h + 1, 1)

End If

If h = 26 Then

st2 = Mid(st1, 26, 1)

End If

Range("A1:" + Trim(st2) + Trim(Str(n + 1))).Select

With Selection.Font

.name = "Arial Cyr"

.Size = 14

.Strikethrough = False

.Superscript = False

.Subscript = False

.OutlineFont = False

.Shadow = False

.Underline = xlUnderlineStyleNone

.ColorIndex = xlAutomatic

End With

Rows("3:3").RowHeight = 18

Range("A1").Select

ActiveCell.FormulaR1C1 = "№"

Range("A2").Select

ActiveCell.FormulaR1C1 = "1"

Range("A3").Select

ActiveCell.FormulaR1C1 = "2"

Range("A2:A3").Select

Selection.AutoFill Destination:=Range("A2:A" + Trim(Str(n + 1))), Type:=xlFillDefault

Range("A2:A" + Trim(Str(n + 1))).Select

Range("B1").Select

ActiveCell.FormulaR1C1 = "1"

Range("C1").Select

ActiveCell.FormulaR1C1 = "2"

Range("B1:C1").Select

Selection.AutoFill Destination:=Range("B1:" + Trim(st2) + "1"), Type:=xlFillDefault

Range("A1:" + Trim(st2) + Trim(Str(n + 1))).Select

With Selection

.HorizontalAlignment = xlCenter

.VerticalAlignment = xlBottom

.WrapText = False

.Orientation = 0

.AddIndent = False

.IndentLevel = 0

.ShrinkToFit = False

.ReadingOrder = xlContext

.MergeCells = False

End With

Range("A1:A" + Trim(Str(n + 1)) + ",A1:" + Trim(st2) + "1").Select

Range("A1").Activate

With Selection.Interior

.ColorIndex = 33

.Pattern = xlSolid

.PatternColorIndex = xlAutomatic

End With

Range("A1:" + Trim(st2) + Trim(Str(n + 1))).Select

Selection.Borders(xlDiagonalDown).LineStyle = xlNone

Selection.Borders(xlDiagonalUp).LineStyle = xlNone

With Selection.Borders(xlEdgeLeft)

.LineStyle = xlContinuous

.Weight = xlThin

.ColorIndex = xlAutomatic

End With

With Selection.Borders(xlEdgeTop)

.LineStyle = xlContinuous

.Weight = xlThin

.ColorIndex = xlAutomatic

End With

With Selection.Borders(xlEdgeBottom)

.LineStyle = xlContinuous

.Weight = xlThin

.ColorIndex = xlAutomatic

End With

With Selection.Borders(xlEdgeRight)

.LineStyle = xlContinuous

.Weight = xlThin

.ColorIndex = xlAutomatic

End With

With Selection.Borders(xlInsideVertical)

.LineStyle = xlContinuous

.Weight = xlThin

.ColorIndex = xlAutomatic

End With

With Selection.Borders(xlInsideHorizontal)

.LineStyle = xlContinuous

.Weight = xlThin

.ColorIndex = xlAutomatic

End With

For i = 1 To n + 1

st1 = "ABCDEFGHIJKLMNOPQRSTUVWXYZ"

h = i

If h > 26 Then

a = h \ 26

If h Mod 26 = 0 Then

stroka1 = Mid(st1, a - 1, 1)

Else

stroka1 = Mid(st1, a, 1)

End If

b = a * 26

c = h - b

If c = 0 Then c = c + 26

stroka2 = Mid(st1, c, 1)

st2 = stroka1 + stroka2

Else

st2 = Mid(st1, h, 1)

End If

If h = 26 Then

st2 = Mid(st1, 26, 1)

End If

Range(Trim(st2) + Trim(Str(i))).Select

With Selection.Interior

.ColorIndex = 33

.Pattern = xlSolid

.PatternColorIndex = xlAutomatic

End With

Next i

Range("C2").Select

End Sub

Sub Solut()

Dim fl As Boolean

Dim flag As Boolean

Dim remnach As Integer

Dim remkon As Integer

Dim remdl As Double

Dim maxdl As Double

Dim putt As Boolean

scount = 1

'Ввод в таблицу результатов начальных данных

For i = 2 To n + 1

For j = 2 To n + 1

If Not ActiveSheet.Cells(i, j).Value = "" Then

scount = scount + 1

Sheets("Rez").Cells(scount, 1).Value = i - 1

Sheets("Rez").Cells(scount, 2).Value = j - 1

Sheets("Rez").Cells(scount, 3).Value = ActiveSheet.Cells(i, j).Value

End If

Next j

Next i

'Поиск начальных этапов

For i = 2 To n + 1

fl = False

For j = 2 To n + 1

If Not ActiveSheet.Cells(j, i).Value = "" Then

fl = True

End If

Next j

If fl = False Then

For j = 2 To scount

If Sheets("Rez").Cells(j, 1).Value = i - 1 Then

Sheets("Rez").Cells(j, 4).Value = 0

Sheets("Rez").Cells(j, 5).Value = Sheets("Rez").Cells(j, 4).Value + Sheets("Rez").Cells(j, 3).Value

End If

Next j

End If

Next i

'Заполнение раннего начала и конца

flag = True

Do While flag = True

flag = False

For i = 2 To scount

If Not Sheets("Rez").Cells(i, 4).Value = "" Then

remkon = Sheets("Rez").Cells(i, 2)

remdl = Sheets("Rez").Cells(i, 5)

For j = 2 To scount

If Sheets("Rez").Cells(j, 2).Value = remkon Then

If remdl < Sheets("Rez").Cells(j, 5).Value Then

remdl = Sheets("Rez").Cells(j, 5).Value

End If

End If

Next j

For j = 2 To scount

If Sheets("Rez").Cells(j, 1).Value = remkon Then

Sheets("Rez").Cells(j, 4).Value = remdl

Sheets("Rez").Cells(j, 5).Value = Sheets("Rez").Cells(j, 4).Value + Sheets("Rez").Cells(j, 3).Value

End If

Next j

End If

Next i

For i = 2 To scount

If Sheets("Rez").Cells(i, 4).Value = "" Then

flag = True

End If

Next i

Loop

'Определение длительности проекта

maxdl = Sheets("Rez").Cells(2, 5).Value

For i = 2 To scount

If maxdl < Sheets("rez").Cells(i, 5).Value Then

maxdl = Sheets("rez").Cells(i, 5).Value

End If

Next i

'Определение конечных этапов

For i = 2 To n + 1

fl = False

For j = 2 To n + 1

If Not ActiveSheet.Cells(i, j).Value = "" Then

fl = True

End If

Next j

If fl = False Then

For j = 2 To scount

If Sheets("Rez").Cells(j, 2).Value = i - 1 Then

Sheets("Rez").Cells(j, 7).Value = maxdl

Sheets("Rez").Cells(j, 6).Value = Sheets("Rez").Cells(j, 7).Value - Sheets("Rez").Cells(j, 3).Value

Sheets("Rez").Cells(j, 8).Value = Sheets("Rez").Cells(j, 7).Value - Sheets("Rez").Cells(j, 5).Value

End If

Next j

End If

Next i

'Заполнение позднего начала и конца

flag = True

Do While flag = True

flag = False

For i = scount To 2 Step -1

If Not Sheets("Rez").Cells(i, 6).Value = "" Then

remnach = Sheets("Rez").Cells(i, 1)

remdl = Sheets("Rez").Cells(i, 6)

For j = scount To 2 Step -1

If Sheets("Rez").Cells(j, 1).Value = remnach Then

If remdl > Sheets("Rez").Cells(j, 6).Value Then

remdl = Sheets("Rez").Cells(j, 6).Value

End If

End If

Next j

For j = scount To 2 Step -1

If Sheets("Rez").Cells(j, 2).Value = remnach Then

Sheets("Rez").Cells(j, 7).Value = remdl

Sheets("Rez").Cells(j, 6).Value = Sheets("Rez").Cells(j, 7).Value - Sheets("Rez").Cells(j, 3).Value

Sheets("Rez").Cells(j, 8).Value = Sheets("Rez").Cells(j, 7).Value - Sheets("Rez").Cells(j, 5).Value

End If

Next j

End If

Next i

For i = 2 To scount

If Sheets("Rez").Cells(i, 6).Value = "" Then

flag = True

End If

Next i

Loop

'Выявление критических этапов

Sheets("Rez").Select

For i = 2 To scount

If Sheets("Rez").Cells(i, 8).Value = 0 Then

Range("A" + Trim(Str(i)) + ":H" + Trim(Str(i))).Select

With Selection.Interior

.ColorIndex = 35

.Pattern = xlSolid

.PatternColorIndex = xlAutomatic

End With

End If

Next i

Sheets("Rez").Cells(scount + 2, 1).Value = "Критический путь:"

'Построение критического пути

snum = 1

For i = 2 To scount

If Sheets("Rez").Cells(i, 8).Value = 0 Then

Sheets("Rez").Cells(scount + 2, 2).Value = Sheets("Rez").Cells(i, 1).Value

Sheets("Rez").Cells(scount + 2, 3).Value = Sheets("Rez").Cells(i, 2).Value

snum = 3

remdl = i

i = scount

End If

Next i

For i = remdl To scount

If Sheets("Rez").Cells(i, 8).Value = 0 Then

Sheets("Rez").Cells(scount + 2, snum).Value = Sheets("Rez").Cells(i, 2).Value

snum = snum + 1

End If

Next i

putt = False

For i = 2 To snum - 1

remdl = Sheets("Rez").Cells(scount + 2, i)

For j = i + 1 To snum

If Sheets("Rez").Cells(scount + 2, j).Value = remdl Then

putt = True

End If

Next j

Next i

If putt = True Then

snum = 1

For i = scount To 2 Step -1

If Sheets("Rez").Cells(i, 8).Value = 0 Then

Sheets("Rez").Cells(scount + 2, 2).Value = Sheets("Rez").Cells(i, 1).Value

Sheets("Rez").Cells(scount, 3).Value = Sheets("Rez").Cells(i, 2).Value

snum = 3

remdl = i

i = 2

End If

Next i

For i = remdl To 2 Step -1

If Sheets("Rez").Cells(i, 8).Value = 0 Then

Sheets("Rez").Cells(scount + 2, snum).Value = Sheets("Rez").Cells(i, 2).Value

snum = snum + 1

End If

Next i

End If

Sheets("Rez").Cells(scount + 2, 1).Select

End Sub

Sub markcell()

Dim mst1 As String

Dim mst2 As String

Dim mstroka1 As String

Dim mstroka2 As String

mst1 = "ABCDEFGHIJKLMNOPQRSTUVWXYZ"

h = j

If h > 26 Then

a = h \ 26

If h Mod 26 = 0 Then

mstroka1 = Mid(mst1, a - 1, 1)

Else

mstroka1 = Mid(mst1, a, 1)

End If

b = a * 26

c = h - b

If c = 0 Then c = c + 26

mstroka2 = Mid(mst1, c, 1)

mst2 = mstroka1 + mstroka2

Else

mst2 = Mid(mst1, h, 1)

End If

If h = 26 Then

mst2 = Mid(mst1, 26, 1)

End If

Range(Trim(mst2) + Trim(Str(i))).Select

End Sub


Информация о работе «Нахождение критического пути табличным методом»
Раздел: Экономико-математическое моделирование
Количество знаков с пробелами: 43657
Количество таблиц: 3
Количество изображений: 3

Похожие работы

Скачать
331723
31
44

... Возникшие потребности в научно обоснованных методах и средствах управления нашли свое выражение в кибернетике - науке об управлении и системном анализе, особым предметом исследования которых являются сложные и очень сложные системы окружающего мира. 4.4 Организационные системы Традиционно современная кибернетика рассматривала, в основном, простые и сложные управляемые системы, для которых ...

Скачать
94425
3
18

... цикла наибольшую сложность составляет определение t мо. Значение остальных составляюших определяется сравнительно легко. Литература: Козловский В.А. и др. Производственный и операционный менеджмент. Учебник – СПб: «Специальная Литература», 1998. с. 276 6. Управление проектами Планирование, расписание и контроллинг проектов Управление большими проектами включает три фазы: 1) ...

Скачать
50998
15
5

... тенденции свидетельствуют о благоприятном развитии экономики, расширении деятельности предприятий и организаций, увеличении предпринимательской активности.2. Расчетная часть   Вариант №2 Тема. Статистические методы изучения инвестиций Имеются следующие выборочные данные по 25-ти однотипным предприятиям одного из регионов РФ, для анализа инвестирования предприятий собственными средствами за ...

Скачать
97981
11
13

... 0 0 0 0 11-12 Разработка электрической схемы пульта проверки 4 5 100 50 12-13 Выбор вариантов конструкции 5 6 100 50 13-14 Расчет параметров конструкции 2 3 70 50 14-15 Разработка печатной платы пульта проверки 7 8 200 180 15-16 Объединение конструкции и платы 7 9 200 150 16-17 Выполнение графической части 8 9 210 170 17-18 Подготовка основной ...

0 комментариев


Наверх