47889 (608403), страница 18
Текст из файла (страница 18)
Cells(row7, col7).Value = Symma
If Symma = 0 Then
Cells(row7, col7).Select
With Selection.Interior
.ColorIndex = 7
.Pattern = xlSolid
End With
ElseIf Symma = Max1 Then
Cells(row7, col7).Select
With Selection.Interior
.ColorIndex = 7
.Pattern = xlSolid
End With
ElseIf Symma <= porog1 Then
Cells(row7, col7).Select
With Selection.Interior
.ColorIndex = 8
.Pattern = xlSolid
End With
ElseIf Symma > porog1 And Symma < Max1 Then
Cells(row7, col7).Select
With Selection.Interior
.ColorIndex = 15
.Pattern = xlSolid
End With
End If
End Sub
Private Sub CommandButton1_Click()
' Очистка области листа со старыми данными
Range("a5:AZ100").Select
Selection.ClearContents
Range("a1").Select
' Убираем с экрана информационное окно
T1.Visible = False
' Подсчет количества учебный дней в неделе
N_Days = 0
While Worksheets(2).Cells(N_Days + 2, 4).Value <> ""
N_Days = N_Days + 1
Wend
' Подсчет количества занятий в течение дня
N_Times = 0
While Worksheets(2).Cells(N_Times + 2, 5).Value <> ""
N_Times = N_Times + 1
Wend
' Подсчет количества аудиторий
N_Rooms = 0
While Worksheets(2).Cells(N_Rooms + 2, 1).Value <> ""
N_Rooms = N_Rooms + 1
Wend
' Расчет количества занятий в течение недели
DaysTimes = N_Days * N_Times
For i = 1 To DaysTimes
For j = 1 To N_Rooms
Cells(6 + j, i + 1) = 0
Next
Next
' Подсчет числа заявителей
N_Boss = 0
While Worksheets(2).Cells(N_Boss + 2, 6).Value <> ""
N_Boss = N_Boss + 1
Wend
Range("b7:AZ100").Select ' Заливка белым цветом области вывода
With Selection.Interior
.ColorIndex = 0
.Pattern = xlSolid
End With
' Подсчет количества строк на 1-м листе
N = 0
While Worksheets(1).Cells(N + 4, 1).Value <> ""
N = N + 1
Wend
' Вывод информации начинаем с седьмой строки
stroka = 7
For i = 1 To N_Rooms ' Заполнение столбца аудиторий
Cells(stroka, 1).Value = Worksheets(2).Cells(i + 1, 1).Value
stroka = stroka + 1
Next
St = 1 ' Заполнение дней и начала занятий
For i = 1 To N_Days
For j = 1 To N_Times
St = St + 1
Cells(5, St).Value = Worksheets(2).Cells(i + 1, 4).Value
Cells(6, St).Value = Worksheets(2).Cells(j + 1, 5).Value
Next
Next
N_Ayd = 0 ' Подсчет аудитоий занесенных на этот лист
While Cells(N_Ayd + 7, 1).Value <> ""
N_Ayd = N_Ayd + 1
Wend
For j = CInt(L1.Text) To CInt(L2.Text) ' Цикл по указанным неделям
For i = 4 To N + 3 ' Цикл по строкам первого листа
If CStr(Worksheets(1).Cells(i, 7).Value) = _
"да" Then ' Если заявка обслужена
Nayd = Worksheets(1).Cells(i, 8).Value
stroka = 0
For m = 1 To N_Rooms
If CStr(Nayd) = CStr(Cells(m + 6, 1).Value) Then
stroka = m + 6
Exit For
End If
Next
' Если не найдена аудитория указанная в строке на первом листе
If stroka = 0 Then
inform_text = "Ошибка в данных в строке " + CStr(i)
MsgBox (inform_text)
'Worksheets(1).Cells(i, 1).Activate
Range("A1").Select
Exit Sub
End If
For m = 1 To DaysTimes
If CStr(Worksheets(1).Cells(i, 4).Value) = CStr(Cells(5, 1 + m).Value) _
And CStr(Worksheets(1).Cells(i, 5).Value) = CStr(Cells(6, 1 + m).Value) Then
stolbec = 1 + m
Exit For
End If
Next
' Фрагмент для учета групповых занятий
If Worksheets(1).Cells(i, j + 11).Value = "*" And Cells(stroka, stolbec).Value < 1000 Then
Cells(stroka, stolbec) = Cells(stroka, stolbec) + 1
Cells(stroka, stolbec) = Cells(stroka, stolbec) + 1000
End If
End If
Next
For ii = 1 To DaysTimes
For jj = 1 To N_Rooms
a = CInt(Cells(jj + 6, ii + 1).Value)
If a >= 1000 Then
Cells(jj + 6, ii + 1).Value = Cells(jj + 6, ii + 1).Value - 1000
End If
Next
Next
Next
' Расцветка занятий
Maximum = CInt(L2.Text) - CInt(L1.Text) + 1
porog = CInt(Maximum / 2) ' Порог - половина занятых дней в указанном интервале
For i = 1 To DaysTimes
For j = 1 To N_Rooms
a = CInt(Cells(j + 6, i + 1).Value) ' Количество занятий
If a = Maximum Then
Cells(j + 6, i + 1).Select
With Selection.Interior
.ColorIndex = 7 ' Расцветка при максимальной занятости
.Pattern = xlSolid
End With
ElseIf a 0 Then
Cells(j + 6, i + 1).Select
With Selection.Interior
.ColorIndex = 8 ' Расцветка при знятости меньше среней
.Pattern = xlSolid
End With
ElseIf a > porog And a < Maximum Then
Cells(j + 6, i + 1).Select
With Selection.Interior
.ColorIndex = 15
.Pattern = xlSolid
End With
End If
Next
Next
Range("a5").Select
T1.Visible = True
End Sub
Private Sub CommandButton2_Click()
F_Podbor.Show
End Sub
Private Sub T1_DblClick(ByVal Cancel As MSForms.ReturnBoolean)
T1.Text = ""
T1.Visible = False
End Sub
Private Sub Worksheet_Activate()
N_Ned = 0
While Worksheets(2).Cells(N_Ned + 2, 3).Value <> ""
N_Ned = N_Ned + 1
Wend
L1.Clear
L2.Clear
For i = 1 To N_Ned
L1.AddItem Worksheets(2).Cells(i + 1, 3).Value
L2.AddItem Worksheets(2).Cells(i + 1, 3).Value
Next
If L1.ListCount > 0 And Sav1 < L1.ListCount Then
L1.ListIndex = Sav1
End If
If L2.ListCount > 0 And Sav2 < L2.ListCount Then
L2.ListIndex = Sav2
End If
Private Sub Worksheet_Deactivate()
Sav1 = L1.ListIndex
Sav2 = L2.ListIndex
End Sub
Private Sub Worksheet_SelectionChange(ByVal Target As Range)
NumStr1 = ActiveCell.Row
NumCol1 = ActiveCell.Column
If NumCol1 <> 1 Then
If T1.Visible = False Then
Exit Sub
End If
T1.Text = ""
N_Days = 0
While Worksheets(2).Cells(N_Days + 2, 4).Value <> ""
N_Days = N_Days + 1
Wend
N_Times = 0
While Worksheets(2).Cells(N_Times + 2, 5).Value <> ""
N_Times = N_Times + 1
Wend
' Количество строк
DaysTimes = N_Days * N_Days
N = 0
While Worksheets(1).Cells(N + 4, 1).Value <> ""
N = N + 1
Wend
'Цикл по строкам первого листа
For i = 1 To N
Day1 = CStr(Worksheets(1).Cells(i + 3, 4).Value)
Time1 = CStr(Worksheets(1).Cells(i + 3, 5).Value)
Group1 = CStr(Worksheets(1).Cells(i + 3, 9).Value)
Prepod1 = CStr(Worksheets(1).Cells(i + 3, 3).Value)
Disp1 = CStr(Worksheets(1).Cells(i + 3, 10).Value)
Aud1 = CStr(Worksheets(1).Cells(i + 3, 8).Value)
Obs1 = CStr(Worksheets(1).Cells(i + 3, 7).Value)
' Если заявка обслужена
If Obs1 = "да" Then
indic = 0
For j = CInt(L1.Text) To CInt(L2.Text)
If CStr(Worksheets(1).Cells(i + 3, 10 + j).Value) = "*" Then
indic = 1
Exit For
End If
Next
' Если интервал недель соответстует
If indic = 1 Then
If Day1 = CStr(Cells(5, NumCol1).Value) And _
Time1 = CStr(Cells(6, NumCol1).Value) _
And CStr(Cells(NumStr1, 1).Value) = Aud1 Then
If T1.Text <> "" Then
T1.Text = T1.Text + Chr(10)
End If
T1.Text = T1.Text + Disp1
T1.Text = T1.Text + " " + Group1
T1.Text = T1.Text + " " + Prepod1 + " "
For j = CInt(L1.Text) To CInt(L2.Text) 'Цикл 1
ask = CStr(Worksheets(1).Cells(i + 3, j + 11).Value)
If ask = "*" Then
T1.Text = T1.Text + " " + Str(j) + ","
End If
Next
End If
End If ' Если интервал недель соответстует
End If 'Если заявка обслужена
Next 'Завершение цикла по строкам первого листа
T3.Visible = False
ElseIf NumStr1 > 6 Then
T3.Visible = True
T3.Text = "Вместимость " + Str(Worksheets(2).Cells(NumStr1 - 5, 2)) + " чел "
End If
End Sub
Приложение 2
Процедура, связанная с открытием книги
Private Sub Workbook_Open()
' Подсчет дней на втором листе
N_Days = 0
While Worksheets(2).Cells(N_Days + 2, 4).Value <> ""
N_Days = N_Days + 1
Wend
' Заполнение списка L1 на 3-м листе
Worksheets(3).L1.Clear
For i = 1 To N_Days
Worksheets(3).L1.AddItem Worksheets(2).Cells(i + 1, 4).Value
Next
' Подсчет занятий в течение дня
N_Times = 0
While Worksheets(2).Cells(N_Times + 2, 5).Value <> ""
N_Times = N_Times + 1
Wend
' Заполнение списка L2 на 3-м листе
Worksheets(3).L2.Clear
For i = 1 To N_Times
Worksheets(3).L2.AddItem CStr(Worksheets(2).Cells(i + 1, 5).Value)
Next
' Подсчет числа недель на втором листе
N_Ned = 0
While Worksheets(2).Cells(N_Ned + 2, 3).Value <> ""
N_Ned = N_Ned + 1
Wend
' Заполнение 3-го списка L3 на 3-м листе
Worksheets(3).L3.Clear
For i = 1 To N_Ned
Worksheets(3).L3.AddItem Worksheets(2).Cells(i + 1, 3).Value
Next
' Заполнение списков недель на 4-м листе
Worksheets(4).C1.Clear
Worksheets(4).C2.Clear
For i = 1 To N_Ned
Worksheets(4).C1.AddItem Worksheets(2).Cells(i + 1, 3).Value
Worksheets(4).C2.AddItem Worksheets(2).Cells(i + 1, 3).Value
Next
' Заполнение списка недель на 8-м листе
Worksheets(8).L1.Clear
For i = 1 To N_Ned
Worksheets(8).L1.AddItem Worksheets(2).Cells(i + 1, 3).Value
Next
' Заполнение списка недель на 9-м листе
Worksheets(9).L1.Clear
Worksheets(9).L2.Clear
For i = 1 To N_Ned
Worksheets(9).L1.AddItem Worksheets(2).Cells(i + 1, 3).Value
Worksheets(9).L2.AddItem Worksheets(2).Cells(i + 1, 3).Value
Next
'Заполнение списка недель на 10-м листе
Worksheets(10).L1.Clear
Worksheets(10).L2.Clear
For i = 1 To N_Ned
Worksheets(10).L1.AddItem Worksheets(2).Cells(i + 1, 3).Value
Worksheets(10).L2.AddItem Worksheets(2).Cells(i + 1, 3).Value
Next
' Подсчет числа преподавателей
N_Prepod = 0
While Worksheets(2).Cells(N_Prepod + 2, 7).Value <> ""
N_Prepod = N_Prepod + 1
Wend
' Заполнение списка преподавателей на листе Нагрузка
Worksheets(12).Prepod.Clear
For i = 1 To N_Prepod
Worksheets(12).Prepod.AddItem Worksheets(2).Cells(i + 1, 7).Value
Next
Worksheets(11).mesac.Clear
Worksheets(11).mesac.AddItem "сентябрь"
Worksheets(11).mesac.AddItem "октябрь"
Worksheets(11).mesac.AddItem "ноябрь"
Worksheets(11).mesac.AddItem "декабрь"
Worksheets(11).mesac.AddItem "январь"
Worksheets(11).mesac.AddItem "февраль"
Worksheets(11).mesac.AddItem "март"
Worksheets(11).mesac.AddItem "апрель"
Worksheets(11).mesac.AddItem "май"
Worksheets(11).mesac.AddItem "июнь"
' Установка защиты на первый и второй листы
Worksheets(1).Protect DrawingObjects:=True, Contents:=True, _
Scenarios:=True
Worksheets(2).Protect DrawingObjects:=True, Contents:=True, _
Scenarios:=True
End Sub
СПИСОК ЛИТЕРАТУРЫ
1 Смирнов Г.Н. «Проектирование экономических информационных систем». Учебник.-М.: Финансы и статистика, 2003.
2. Емельянова Н.З. и др. «Основы построения автоматизированных систем». Учебное пособие. – М.: Форум: ИНФРА-М,2005.
3. Гарнаев А.Ю. «Самоучитель VBA.» СПБ.:БХВ-Петеребург,2004.
4. Уокенбах Д. «Профессиональное программирование на VBA в Exel 2002».: Перевод с английского. – М.: Издательский дом «Вильямс», 2003
167
![](https://s.studizba.com/z.php?f=/templates/si/i/noavatar.png&w=100&h=100&t=1"){kind=avatar}
