For i = 4 To N + 3 ' Проверка занятий
For j = 1 To ColZ
If i = mZ(j) Then
GoTo Nexti2 ' Обходим копируемую заявку
End If
Next
a_i = CStr(Worksheets(1).Cells(i, 8).Value)
d_i = CStr(Worksheets(1).Cells(i, 4).Value)
v_i = CStr(Worksheets(1).Cells(i, 5).Value)
o_i = CStr(Worksheets(1).Cells(i, 7).Value)
If o_i <> "да" Then ' Если заявка необслужена, то ее обходим
GoTo Nexti2
End If
For j = 1 To ColZ ' Цикл по количеству перемещаемых заявок
If audN = a_i And denN = d_i And vremZ = v_i Then
' При совпадении аудитории, дня и времени
For m = 0 To 17
If Worksheets(1).Cells(i, 11 + m).Value = "*" _
And Worksheets(1).Cells(mZ(j), 11 + m).Value = "*" Then
flagZ = 1 ' Если есть перекрытие хотя бы по одной неделе,
Exit For ' то копирование невозможно
End If
Next ' Цикл по неделям
End If
If flagZ = 1 Then
Exit For
End If
Next ' Цикл по количеству перемещаемых заявок
If flagZ = 1 Then
Exit For
End If
Nexti2: Next ' Завершение проверки
If flagZ = 1 Then ' Если копирование невозможно, то выводим соответствующее сообщение
MsgBox ("Заявку не удается перенести. Аудиторное время занято.")
Max1 = CInt(L2.Text) - CInt(L1.Text) + 1
porog1 = CInt(Max1 / 2)
row7 = NumStr
col7 = NumCol
a = CInt(Cells(row7, col7).Value)
If a = 0 Then
ElseIf a = Max1 Then
Cells(row7, col7).Select
With Selection.Interior
.ColorIndex = 7
.Pattern = xlSolid
End With
ElseIf a <= porog1 Then
Cells(row7, col7).Select
With Selection.Interior
.ColorIndex = 8
.Pattern = xlSolid
End With
ElseIf a > porog1 And a < Max1 Then
Cells(row7, col7).Select
With Selection.Interior
.ColorIndex = 15
.Pattern = xlSolid
End With
End If
Exit Sub
End If
'Цикл по количеству копированных заявок
Worksheets(1).Unprotect
For ia = 1 To ColZ
Nom = 0
While Worksheets(1).Cells(Nom + 4, 1).Value <> ""
Nom = Nom + 1
Wend
Worksheets(1).Cells(Nom + 4, 1).Value = Worksheets(1).Cells(mZ(ia), 1).Value
Worksheets(1).Cells(Nom + 4, 2).Value = Worksheets(1).Cells(mZ(ia), 2).Value
Worksheets(1).Cells(Nom + 4, 3).Value = Worksheets(1).Cells(mZ(ia), 3).Value
Worksheets(1).Cells(Nom + 4, 4).Value = denN
Worksheets(1).Cells(Nom + 4, 5).Value = vremZ
Worksheets(1).Cells(Nom + 4, 6).Value = Worksheets(1).Cells(mZ(ia), 6).Value
Worksheets(1).Cells(Nom + 4, 7).Value = Worksheets(1).Cells(mZ(ia), 7).Value
Worksheets(1).Cells(Nom + 4, 8).Value = audN
For uo = 9 To 28
Worksheets(1).Cells(Nom + 4, uo).Value = Worksheets(1).Cells(mZ(ia), uo).Value
Next
Next
' Завершение цикла по количеству копированных заявок
' Удаление заявок
For oi = ColZ To 1 Step -1
i = mZ(oi)
Worksheets(1).Rows(i).Delete
Next
Worksheets(1).Protect DrawingObjects:=True, Contents:=True, Scenarios:=True
Cells(NumStr, NumCol).Value = "0"
Cells(NumStr, NumCol).Select
With Selection.Interior
.ColorIndex = 0
.Pattern = xlSolid
End With
Max1 = CInt(L2.Text) - CInt(L1.Text) + 1
porog1 = CInt(Max1 / 2)
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 <= porog And 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