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, 4
|