N_Days = N_Days + 1
Wend
' Подсчет количества занятий в течение дня
N_Times = 0
While Worksheets(2).Cells(N_Times + 2, 5).Value <> ""
N_Times = N_Times + 1
' Подсчет количества аудиторий
N_Rooms = 0
While Worksheets(2).Cells(N_Rooms + 2, 1).Value <> ""
N_Rooms = N_Rooms + 1
' Расчет количества занятий в течение недели
DaysTimes = N_Days * N_Times
For i = 1 To DaysTimes
For j = 1 To N_Rooms
Cells(6 + j, i + 1) = 0
Next
' Подсчет числа заявителей
N_Boss = 0
While Worksheets(2).Cells(N_Boss + 2, 6).Value <> ""
N_Boss = N_Boss + 1
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
' Вывод информации начинаем с седьмой строки
stroka = 7
For i = 1 To N_Rooms ' Заполнение столбца аудиторий
Cells(stroka, 1).Value = Worksheets(2).Cells(i + 1, 1).Value
stroka = stroka + 1
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
N_Ayd = 0 ' Подсчет аудитоий занесенных на этот лист
While Cells(N_Ayd + 7, 1).Value <> ""
N_Ayd = N_Ayd + 1
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
' Если не найдена аудитория указанная в строке на первом листе
If stroka = 0 Then
inform_text = "Ошибка в данных в строке " + CStr(i)
MsgBox (inform_text)
'Worksheets(1).Cells(i, 1).Activate
Range("A1").Select
Exit Sub
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
' Фрагмент для учета групповых занятий
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
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
' Расцветка занятий
Maximum = CInt(L2.Text) - CInt(L1.Text) + 1
porog = CInt(Maximum / 2) ' Порог - половина занятых дней в указанном интервале
a = CInt(Cells(j + 6, i + 1).Value) ' Количество занятий
If a = Maximum Then
Cells(j + 6, i + 1).Select
.ColorIndex = 7 ' Расцветка при максимальной занятости
ElseIf a <= porog And a > 0 Then
.ColorIndex = 8 ' Расцветка при знятости меньше среней
ElseIf a > porog And a < Maximum Then
.ColorIndex = 15
Range("a5").Select
T1.Visible = True
End Sub
Private Sub CommandButton2_Click()
F_Podbor.Show
Private Sub T1_DblClick(ByVal Cancel As MSForms.ReturnBoolean)
T1.Text = ""
T1.Visible = False
Private Sub Worksheet_Activate()
N_Ned = 0
While Worksheets(2).Cells(N_Ned + 2, 3).Value <> ""
N_Ned = N_Ned + 1
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
If L1.ListCount > 0 And Sav1 < L1.ListCount Then
L1.ListIndex = Sav1
If L2.ListCount > 0 And Sav2 < L2.ListCount Then
L2.ListIndex = Sav2
Private Sub Worksheet_Deactivate()
Sav1 = L1.ListIndex
Sav2 = L2.ListIndex
Private Sub Worksheet_SelectionChange(ByVal Target As Range)
NumStr1 = ActiveCell.Row
NumCol1 = ActiveCell.Column
If NumCol1 <> 1 Then
If T1.Visible = False Then
N_Days = 0
While Worksheets(2).Cells(N_Days + 2, 4).Value <> ""
' Количество строк
DaysTimes = N_Days * N_Days
'Цикл по строкам первого листа
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
' Если интервал недель соответстует
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)
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 ' Если интервал недель соответстует
End If 'Если заявка обслужена
Next 'Завершение цикла по строкам первого листа
T3.Visible = False
ElseIf NumStr1 > 6 Then
T3.Visible = True
T3.Text = "Вместимость " + Str(Worksheets(2).Cells(NumStr1 - 5, 2)) + " чел "
Приложение 2
Процедура, связанная с открытием книги
Private Sub Workbook_Open()
' Подсчет дней на втором листе
' Заполнение списка L1 на 3-м листе
Worksheets(3).L1.Clear
Worksheets(3).L1.AddItem Worksheets(2).Cells(i + 1, 4).Value
' Подсчет занятий в течение дня
' Заполнение списка L2 на 3-м листе
Worksheets(3).L2.Clear
For i = 1 To N_Times
Worksheets(3).L2.AddItem CStr(Worksheets(2).Cells(i + 1, 5).Value)
' Подсчет числа недель на втором листе
' Заполнение 3-го списка L3 на 3-м листе
Worksheets(3).L3.Clear
Worksheets(3).L3.AddItem Worksheets(2).Cells(i + 1, 3).Value
' Заполнение списков недель на 4-м листе
Worksheets(4).C1.Clear
Worksheets(4).C2.Clear
Worksheets(4).C1.AddItem Worksheets(2).Cells(i + 1, 3).Value
Worksheets(4).C2.AddItem Worksheets(2).Cells(i + 1, 3).Value
' Заполнение списка недель на 8-м листе
Worksheets(8).L1.Clear
Worksheets(8).L1.AddItem Worksheets(2).Cells(i + 1, 3).Value
' Заполнение списка недель на 9-м листе
Worksheets(9).L1.Clear
Worksheets(9).L2.Clear
Worksheets(9).L1.AddItem Worksheets(2).Cells(i + 1, 3).Value
Worksheets(9).L2.AddItem Worksheets(2).Cells(i + 1, 3).Value
'Заполнение списка недель на 10-м листе
Worksheets(10).L1.Clear
Worksheets(10).L2.Clear
Worksheets(10).L1.AddItem Worksheets(2).Cells(i + 1, 3).Value
Worksheets(10).L2.AddItem Worksheets(2).Cells(i + 1, 3).Value
' Подсчет числа преподавателей
N_Prepod = 0
While Worksheets(2).Cells(N_Prepod + 2, 7).Value <> ""
N_Prepod = N_Prepod + 1
' Заполнение списка преподавателей на листе Нагрузка
Worksheets(12).Prepod.Clear
For i = 1 To N_Prepod
Worksheets(12).Prepod.AddItem Worksheets(2).Cells(i + 1, 7).Value
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, _
СПИСОК ЛИТЕРАТУРЫ
1 Смирнов Г.Н. «Проектирование экономических информационных систем». Учебник.-М.: Финансы и статистика, 2003.
2. Емельянова Н.З. и др. «Основы построения автоматизированных систем». Учебное пособие. – М.: Форум: ИНФРА-М,2005.
3. Гарнаев А.Ю. «Самоучитель VBA.» СПБ.:БХВ-Петеребург,2004.
4. Уокенбах Д. «Профессиональное программирование на VBA в Exel 2002».: Перевод с английского. – М.: Издательский дом «Вильямс», 2003
Страницы: 1, 2, 3, 4, 5, 6, 7, 8, 9, 10, 11, 12, 13, 14, 15, 16, 17, 18, 19, 20, 21, 22, 23, 24
