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

Страницы: 1, 2, 3