Public Sub UserForm1_Initialize()
  ' Процедура активизации диалогового окна Регистрация туристов
  ' и задание элементов раскрывающегося списка

  ' Проверка наличия заголовка базы данных.
  ' Построение заголовка базы данных в случае его отсутствия
  If Sheets("БазаДанных").Range("A1").Value <> "Фамилия" Then
    ЗаголовокЛиста
  End If
  
  ' Задание элементов раскрывающегося списка
  With UserForm1
    .CommandButton1.Default = True
    .CommandButton2.Cancel = True
    .ComboBox1.List = Array("Афины", "Берлин", "Лондон")
    .ComboBox1.ListIndex = 0
    .OptionButton1.Value = True
    .SpinButton1.Value = 1
    .CheckBox1.Value = False
    .CheckBox2.Value = False
    .CheckBox3.Value = False
  End With

  ' Активизация диалогового окна
  UserForm1.Show
End Sub

Public Sub ЗаголовокЛиста()
  With Sheets("БазаДанных")
    .Range("A1").Value = "Фамилия"
    .Range("B1").Value = "Имя"
    .Range("C1").Value = "Пол"
    .Range("D1").Value = "Направление тура"
    .Range("E1").Value = "Оплачено"
    .Range("F1").Value = "Фото сданы"
    .Range("G1").Value = "Паспорт сдан"
    .Range("H1").Value = "Продолжительность"
    .Range("A:A").ColumnWidth = 9.43
    .Range("B:C").ColumnWidth = 8.43
    .Range("D:D").ColumnWidth = 13.43
    .Range("E:E").ColumnWidth = 10.14
    .Range("F:F").ColumnWidth = 9
    .Range("G:G").ColumnWidth = 8.43
    .Range("H:H").ColumnWidth = 19.14
  End With

  Sheets("БазаДанных").Rows("1:1").Select
  With Selection
    .Font.Bold = True
    .HorizontalAlignment = xlGeneral
    .VerticalAlignment = xlTop
    .WrapText = True
    With .Interior
      .ColorIndex = 36
      .Pattern = xlSolid
    End With
  End With
  Sheets("БазаДанных").Rows("2:2").Select
  ActiveWindow.FreezePanes = True
End Sub

Public Sub Запись()
  ActiveWorkbook.Save
End Sub

Private Sub UserForm3_Initialize()
  ' Процедура активизации диалогового окна Поиск
  UserForm3.Show
End Sub

Private Sub Автофильтр()
  ' Процедура вызова команды Автофильтр
  Sheets("БазаДанных").Range("A1:H1").Select
  Selection.AutoFilter
End Sub

Private Sub UserForm4_Initialize()
  ' Процедура активизации диалогового окна фильтрации
  With UserForm4
    .OptionButton1.Value = True
    .Show
  End With
End Sub

Private Sub Сортировка()
  ' Процедура сортировки данных
  ' Первоначальный критерий сортировки - направление тура,
  ' второстепенный - произведение оплаты

  Dim n As Integer
  ' n - вспомогательная переменная
  Sheets("БазаДанных").Range("A2").Select
  n = Selection.CurrentRegion.Rows.Count    '

  ' Определение числа записей в базе данных
  Worksheets("БазаДанных").Range(Cells(2, 1), Cells(n + 1, 8)).Sort _
    key1:=Worksheets("БазаДанных").Range("D2"), _
    order1:=xlAscending, _
    key2:=Worksheets("БазаДанных").Range("E2"), _
    order2:=xlDescending

  ' Сортировка по турам в возрастающем,
  ' а по оплате - в убывающем порядке
End Sub

Private Sub СводнаяТаблица()
  ' Процедура построения сводной таблицы
  Dim n As Integer
  Dim i As Integer
  Dim Списки, Назначение As String
  Dim Лист As Object
  Dim ИмяКниги As String
  ИмяКниги = ActiveWorkbook.Name

  ' Исключаем расширение из имени книги
  For i = 1 To Len(ИмяКниги)
    If Mid(ИмяКниги, i, 1) = "." Then
      ИмяКниги = Mid(ИмяКниги, 1, i - 1)
      Exit For
    End If
  Next i
  ИмяКниги = Trim(ИмяКниги)
  
  ' Удаляются ранее созданные рабочие листы с именем СводнаяТаблица
  For Each Лист In Worksheets
    If Лист.Name = "СводнаяТаблица" Then
      Sheets("СводнаяТаблица").Delete
    End If
  Next Лист

  ' Создается новый рабочий лист с именем СводнаяТаблица
  Worksheets.Add
  ActiveSheet.Name = "СводнаяТаблица"
  n = Worksheets("БазаДанных").Range("A2").CurrentRegion.Rows.Count

  ' Определение диапазона, по которому будет строиться
  ' сводная таблица (Списки) и где она будет расположена (Назначение).
  ' Эти диапазоны записываются в виде строковых выражений
  Списки = "БазаДанных!R1C1:R" & CStr(n) & "C8"
  Назначение = "[" & ИмяКниги & "]СводнаяТаблица!R1C1"

  ' Создание сводной таблицы
  ActiveSheet.PivotTableWizard SourceType:=xlDatabase, _
    SourceData:=Списки, TableDestination:=Назначение, TableName:="Отчет"

  ActiveSheet.PivotTables("Отчет").AddFields _
    RowFields:="Направление тура", ColumnFields:="Оплачено"
  With ActiveSheet.PivotTables("Отчет").PivotFields("Продолжительность")
    .Orientation = xlDataField
    .Name = "Сумма по полю Продолжительность"
    .Function = xlSum
  End With

  ' Построение диаграммы по сводной таблице
  Dim СводнаяТаблица As PivotTable
  Dim Диапазон As Range
  Set СводнаяТаблица = ActiveSheet.PivotTables("Отчет")
  With ActiveSheet.PivotTables("Отчет")
    ' He отображаются итоги по строкам и столбцам
    .RowGrand = False
    .ColumnGrand = False
  End With

  ' Определение диапазона из сводной таблицы,
  ' по которому строится диаграмма
  Set Диапазон = ActiveSheet.PivotTables("Отчет").TableRange1

  ' Построение диаграммы
  Charts.Add
  ActiveChart.ChartType = xlColumnClustered
  ActiveChart.SetSourceData Source:=Диапазон, PlotBy:=xlColumns
  ActiveChart.Location Where:=xlLocationAsObject, Name:="СводнаяТаблица"
  With ActiveChart
    .HasTitle = False
    .Axes(xlCategory, xlPrimary).HasTitle = False
    .Axes(xlValue, xlPrimary).HasTitle = True
    .Axes(xlValue, xlPrimary).AxisTitle.Characters.Text = _
      "Продолжительность оплаченных/неоплаченных поездок"
  End With
End Sub

Sub СохранитьКак()
  ' Процедура активизирует встроенное окно Сохранение документа
  Application.Dialogs(xlDialogSaveAs).Show
End Sub

Sub Закрыть()
  ' Процедура закрытия приложения
  Application.Quit
End Sub