Текст книги "Excel. Трюки и эффекты"

Вывод списка диаграмм в отдельном окне

В процессе работы иногда бывает необходимо узнать, какие диаграммы содержит текущий рабочий лист или книга. В данном разделе мы рассмотрим несколько макросов, позволяющих решить эту задачу.

К примеру, если необходимо быстро узнать количество внедренных диаграмм текущего рабочего листа, то можно воспользоваться следующим макросом (листинг 4.7).

Листинг 4.7. Внедренные диаграммы

Sub ShowSheetCharts()

Dim strMessage As String

Dim i As Integer

' Формирование списка диаграмм

For i = 1 To ActiveSheet.ChartObjects.Count

strMessage = strMessage & ActiveSheet.ChartObjects(i).Name _

& vbNewLine

Next i

' Отображение списка

MsgBox strMessage

End Sub

После выполнения данного макроса на экране отобразится окно с перечнем имен внедренных диаграмм активного рабочего листа.

Можно вывести список рабочих листов, содержащих обычные диаграммы (вынесенные на отдельный рабочий лист). Пример макроса, позволяющего решить эту задачу, приведен в листинге 4.8.

Листинг 4.8. Перечень рабочих листов, содержащих обычные диаграммы

Sub ShowBookCharts()

Dim crt As chart

Dim strMessage As String

' Формирование списка диаграмм

For Each crt In ActiveWorkbook.Charts

strMessage = strMessage & crt.Name & vbNewLine

Next

' Отображение списка

MsgBox strMessage

End Sub

После применения данного макроса появится окно с перечнем рабочих листов текущей книги, содержащих диаграммы.

Применение случайной цветовой палитры

Рассматриваемый в данном разделе трюк носит чисто эргономический характер. С его помощью можно при работе с внедренными диаграммами применять совершенно случайные цвета заливки элементов диаграммы.

Для получения эффекта случайной цветовой палитры можно использовать следующий макрос (листинг 4.9).

Листинг 4.9. Случайная цветовая палитра

Sub RandomChartColors()

Dim intGradientStyle As Integer, intGradientVariant As

Integer

Dim i As Integer

' Проверка, выделена ли диаграмма

If ActiveChart Is Nothing Then Exit Sub

' Изменение оформления всех категорий

For i = 1 To ActiveChart.SeriesCollection.Count

With ActiveChart.SeriesCollection(i)

' Вид градиентной заливки (случайный)

intGradientStyle = Int(Rnd * 7) + 1

If intGradientStyle = 6 Then intGradientStyle = 1

If intGradientStyle = 7 Then

intGradientVariant = Int(Rnd * 2) + 1

Else

intGradientVariant = Int(Rnd * 4) + 1

End If

' Применение градиента

.Fill.TwoColorGradient Style:=intGradientStyle, _

Variant:=intGradientVariant

' Установка случайных цветов фона и обводки (используются _

для градиента)

.Fill.ForeColor.SchemeColor = Int(Rnd * 57) + 1

.Fill.BackColor.SchemeColor = Int(Rnd * 57) + 1

End With

Next i

End Sub

Чтобы изменить цветовую палитру диаграммы, необходимо выделить ее и запустить данный макрос.

Эффект прозрачности диаграммы

С помощью несложного трюка можно сделать так, что диаграмма будет прозрачной. Для этого применим, например, такой макрос (листинг 4.10).

Листинг 4.10. Эффект прозрачности диаграммы

Sub TransparentChart()

Dim shpShape As Shape

Dim dblColor As Double

Dim srSerie As Series

Dim intBorderLineStyle As Integer

Dim intBorderColorIndex As Integer

Dim intBorderWeight As Integer

' Проверка, есть ли выделенная диаграмма

If ActiveChart Is Nothing Then Exit Sub

' Изменение отображения каждой категории

For Each srSerie In ActiveChart.SeriesCollection

If (srSerie.ChartType = xlColumnClustered Or _

srSerie.ChartType = xlColumnStacked Or _

srSerie.ChartType = xlColumnStacked100 Or _

srSerie.ChartType = xlBarClustered Or _

srSerie.ChartType = xlBarStacked Or _

srSerie.ChartType = xlBarStacked100) Then

' Сохранение прежнего цвета категории

dblColor = srSerie.Interior.Color

' Сохранение стиля линий

intBorderLineStyle = srSerie.Border.LineStyle

' Цвет границы

intBorderColorIndex = srSerie.Border.ColorIndex

' Толщина линий границы

intBorderWeight = srSerie.Border.Weight

' Создание автофигуры

Set shpShape = ActiveSheet.shapes.AddShape _

(msoShapeRectangle, 1, 1, 100, 100)

With shpShape

' Закрашиваем нужным цветом

.Fill.ForeColor.RGB = dblColor

' Делаем прозрачной

.Fill.Transparency = 0.4

' Убираем линии

.Line.Visible = msoFalse

End With

' Копируем автофигуру в буфер обмена

shpShape.CopyPicture Appearance:=xlScreen, _

Format:=xlPicture

' Вставляем автофигуру в изображения столбцов _

категории и настраиваем

With srSerie

' Собственно вставка

.Paste

' Возвращаем на место толщину линий

.Border.Weight = intBorderWeight

' Стиль линий

.Border.LineStyle = intBorderLineStyle

' Цвет границы

.Border.ColorIndex = intBorderColorIndex

End With

' Автофигура больше не нужна

shpShape.Delete

End If

Next srSerie

End Sub

После применения данного макроса диаграмма станет прозрачной. Степень прозрачности указывается в строке. Fill. Transparency = 0. 4 – в приведенном примере она равна 40 %. При необходимости данный параметр можно изменить по своему усмотрению. Например, на рис. 4.7 показана диаграмма, у которой прозрачность составляет 60 % (эта же диаграмма изображена на рис. 4.4 в непрозрачном виде).

Данный трюк применяется к созданным ранее диаграммам.

Рис. 4.7. Прозрачная диаграмма

Построение диаграммы на основе данных нескольких рабочих листов

В процессе работы нередко возникает необходимость в оперативной обработке данных, которые хранятся на нескольких рабочих листах. Как известно, одним из способов обработки информации является построение диаграмм. В этом разделе мы рассмотрим, каким образом можно построить одновременно несколько диаграмм, исходными данными для которых будет информация, расположенная на нескольких рабочих листах.

Предположим, что у нас имеются пять разных таблиц, которые расположены на пяти рабочих листах, причем количество строк в этих таблицах различается. Одна из таких таблиц показана на рис. 4.8.

Рис. 4.8. Пример таблицы

Для построения диаграмм на основании данных, хранящихся в этих таблицах, можно использовать макрос, код которого приведен в листинге 4.11.

Листинг 4.11. Одновременное создание нескольких диаграмм

Sub ManyCharts()

Dim intTop As Long, intLeft As Long

Dim intHeight As Long, intWidth As Long

Dim sheet As Worksheet

Dim lngFirstRow As Long ' Первая строка с данными

Dim intSerie As Integer ' Текущая категория диаграммы

Dim strErrorSheets As String ' Список листов, для которых _

не удалось построить диаграммы

intTop = 1 ' Верхняя точка первой диаграммы

intLeft = 1 ' Левая точка каждой диаграммы

intHeight = 180 ' Высота каждой диаграммы

intWidth = 300 ' Ширина каждой диаграммы

' Построение диаграммы для каждого листа, кроме текущего

For Each sheet In ActiveWorkbook.Worksheets

If sheet.Name <> ActiveSheet.Name Then

' Первый заполненный ряд

lngFirstRow = 3

' Первая категория

intSerie = 1

On Error GoTo DiagrammError

' Добавление и настройка диаграммы

With ActiveSheet.ChartObjects.Add _

(intLeft, intTop, intWidth, intHeight).Chart

Do Until IsEmpty(sheet.Cells(lngFirstRow + intSerie, 1))

' Создание ряда

.SeriesCollection.NewSeries

' Значения для ряда

.SeriesCollection(intSerie).Values = _

sheet.Range(sheet.Cells(lngFirstRow + intSerie, 2), _

sheet.Cells(lngFirstRow + intSerie, 4))

' Диапазон данных для подписей

.SeriesCollection(intSerie).XValues = _

sheet.Range(«B3:D3»)

' Название ряда (берется из столбца "A" таблицы

с данными)

.SeriesCollection(intSerie).Name = sheet.Cells( _

lngFirstRow + intSerie, 1)

intSerie = intSerie + 1

Loop

' Настройка внешнего вида диаграммы

.ChartType = xl3DColumnClustered

.ChartGroups(1).GapWidth = 20

.PlotArea.Interior.ColorIndex = xlNone

.ChartArea.Font.Size = 9

' Диаграмма с легендой

.HasLegend = True

' Заголовок

.HasTitle = True

.ChartTitle.Characters.Text = sheet.Range(«A1»)

' Задание диапазона значений на осях

.Axes(xlValue).MinimumScale = 0

.Axes(xlValue).MaximumScale = 120000

' Стиль линий сетки (прерывистый)

.Axes(xlValue).MajorGridlines.Border. _

LineStyle = xlDot

End With

On Error GoTo 0

' Сдвиг верхней точки следующей диаграммы на высоту _

текущей диаграммы

intTop = intTop + intHeight

AfterError:

End If

Next sheet

If strErrorSheets <> "" Then

' Отобразим список листов, для которых не построили диаграммы

MsgBox «Не удалось построить диаграммы для листов:» &

Chr(13) _

& strErrorSheets, vbExclamation

End If

Exit Sub

DiagrammError:

' Добавление в список имени листа, для которого не смогли _

построить диаграмму (ошибка в данных для диаграммы)

strErrorSheets = strErrorSheets & sheet.Name & Chr(13)

' Удаление пустой диаграммы на текущем листе

ActiveSheet.ChartObjects(ActiveSheet.ChartObjects.Count).Delete

' Продолжаем работу с другими листами

Resume AfterError

End Sub

Перед запуском макроса нужно создать пустой рабочий лист для диаграмм. Макрос следует запускать, находясь на этом рабочем листе. В результате выполнения макроса будет создано сразу пять диаграмм, расположенных одна под другой, – по диаграмме для каждой таблицы. Диаграммам будут присвоены названия в соответствии со значением, хранящимся в ячейке А1 (например, на рис. 4.8 в данной ячейке хранится значение Таблица 4, поэтому и соответствующая ей диаграмма будет называться Таблица 4). Особо следует отметить, что приведенный макрос корректно обрабатывает данные в разных таблицах, несмотря на то что количество строк в них различается.

Создание подписей к данным диаграммы

Опытным пользователям Excel известно, что порядок добавления подписей на диаграммы оставляет желать лучшего. В данном разделе мы рассмотрим прием, который позволяет быстро создать подписи к точкам диаграммы.

Диаграмма, а также исходные данные, на основании которых она построена, приведены на рис. 4.9.

Рис. 4.9. Диаграмма без подписей

Для управления отображением подписями к точкам диаграммы нужно в стандартном модуле редактора VBА написать следующий код (листинг 4.12).

Листинг 4.12. Подписи к данным диаграммы

Sub ShowLabels()

Dim rgLabels As Range ' Диапазон с подписями

Dim chrChart As Chart ' Диаграмма

Dim intPoint As Integer ' Точка, для которой добавляется

подпись

' Определение диаграммы

Set chrChart = ActiveSheet.ChartObjects(1).Chart

' Запрос на ввод диапазона с исходными данными

On Error Resume Next

Set rgLabels = Application.InputBox _

(prompt:="Укажите диапазон с подписями", Type:=8)

If rgLabels Is Nothing Then Exit Sub

On Error GoTo 0

' Добавление подписей

chrChart.SeriesCollection(1).ApplyDataLabels _

Type:=xlDataLabelsShowValue, _

AutoText:=True, _

LegendKey:=False

' Просмотр диапазона и назначение подписей

For intPoint = 1 To chrChart.SeriesCollection(1).Points.Count

chrChart.SeriesCollection(1). _

Points(intPoint).DataLabel.Text = rgLabels(intPoint)

Next intPoint

End Sub

Sub DeleteLabels()

' Удаление подписей диаграммы

ActiveSheet.ChartObjects(1).Chart.SeriesCollection(1). _

HasDataLabels = False

End Sub

В результате написания данного кода будут созданы два макроса: ShowLabels (для включения подписей) и DeleteLabels (для их выключения). После выполнения макроса ShowLabels откроется диалоговое окно, в котором нужно указать диапазон исходных данных для создания подписей.

На рис. 4.10 показана диаграмма с подписями.

Рис. 4.10. Диаграмма с подписями

В данном случае в качестве исходных данных для создания подписей был использован диапазон А2:А9.

Глава 5
Создание полезных программ

В данной главе приведено несколько конкретных примеров создания приложений для дальнейшего их использования в Microsoft Excel.

Программа для составления кроссвордов

В этом разделе мы рассмотрим, каким образом, используя механизм пользовательских форм и механизм макросов, можно создать программу для быстрого составления кроссвордов.

В первую очередь нам необходимо создать рабочую книгу с листом. В стандартном модуле следует написать код, который приведен в листинге 5.1. В дальнейшем мы подробнее рассмотрим назначение макросов, которые будут созданы после написания кода.

Листинг 5.1. Программа для составления кроссворда

Const dhcMinCol = 1 ' Номер первого столбца кроссворда

Const dhcMaxCol = 35 ' Номер последнего столбца кроссворда

Const dhcMinRow = 1 ' Номер первой строки кроссворда

Const dhcMaxRow = 35 ' Номер последней строки кроссворда

Sub Clear()

' Выделение и очистка всех используемых для кроссворда ячеек

Range(Cells(dhcMinRow, dhcMinCol), _

Cells(dhcMaxRow, dhcMaxCol)).Select

Selection.Clear

' Удаление сетки всего кроссворда

ClearGrid

Range(«A1»).Select

End Sub

Sub ClearGrid()

' Удаление сетки кроссворда (в выделенных ячейках)...

' Возврат прежнего цвета ячеек

Selection.Interior.ColorIndex = xlNone

' Задание начертания границ ячеек по умолчанию

Selection.Borders(xlDiagonalDown).LineStyle = xlNone

Selection.Borders(xlDiagonalUp).LineStyle = xlNone

Selection.Borders(xlEdgeLeft).LineStyle = xlNone

Selection.Borders(xlEdgeTop).LineStyle = xlNone

Selection.Borders(xlEdgeBottom).LineStyle = xlNone

Selection.Borders(xlEdgeRight).LineStyle = xlNone

Selection.Borders(xlInsideVertical).LineStyle = xlNone

Selection.Borders(xlInsideHorizontal).LineStyle = xlNone

End Sub

Sub DrowCrosswordGrid()

' Процедура начертания сетки кроссворда

' Задание цвета всех ячеек кроссворда

Selection.Interior.ColorIndex = 35

' Линии по диагонали не нужны

Selection.Borders(xlDiagonalDown).LineStyle = xlNone

Selection.Borders(xlDiagonalUp).LineStyle = xlNone

' Задание начертания границ всех диапазонов, входящих _

в выделение, а также границ между соседними ячейками _

всех диапазонов

On Error Resume Next

' Левые границы

With Selection.Borders(xlEdgeLeft)

.LineStyle = xlContinuous

.Weight = xlThin

.ColorIndex = xlAutomatic

End With

' Правые границы

With Selection.Borders(xlEdgeRight)

.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(xlInsideVertical)

.LineStyle = xlContinuous

.Weight = xlThin

.ColorIndex = xlAutomatic

End With

' Горизонтальные границы между ячейками

With Selection.Borders(xlInsideHorizontal)

.LineStyle = xlContinuous

.Weight = xlThin

.ColorIndex = xlAutomatic

End With

End Sub

Sub DisplayGrid()

' Включение сетки на листе

ActiveWindow.DisplayGridlines = True

End Sub

Sub HideGrid()

' Выключение сетки на листе

ActiveWindow.DisplayGridlines = False

End Sub

Sub AutoNumber()

' Нумерация клеток, являющихся началом слов

Dim intRow As Integer ' Текущая строка

Dim intCol As Integer ' Текущий ряд

Dim cell As Range ' Текущая ячейка (с координатами _

(intRow, intCol))

Dim fTop As Boolean ' = True, если cell имеет соседей сверху

Dim fBottom As Boolean ' = True, если cell имеет соседей снизу

Dim fLeft As Boolean ' = True, если cell имеет соседей слева

Dim fRight As Boolean ' = True, если cell имеет соседей справа

Dim intDigit As Integer ' Текущий номер слова в кроссворде

intDigit = 1 ' Нумерация слов с 1

' Проходим по всем клеткам диапазона, используемого _

для кроссворда, сверху вниз слева направо и анализируем _

каждую угловую и крайнюю (левую и верхнюю) ячейки

For intRow = dhcMinRow To dhcMaxRow

For intCol = dhcMinCol To dhcMaxCol

' Текущая ячейка

Set cell = Cells(intRow, intCol)

' Проверка, входит ли ячейка в кроссворд (по ее цвету)

If cell.Interior.ColorIndex = 35 Then

fLeft = False

fRight = False

fTop = False

fBottom = False

On Error Resume Next

' Определение наличия соседей у ячейки...

' сверху

fTop = cell.Offset(-1, 0).Interior.ColorIndex = 35

' снизу

fBottom = cell.Offset(1, 0).Interior.ColorIndex = 35

' слева

fLeft = cell.Offset(0, -1).Interior.ColorIndex = 35

' справа

fRight = cell.Offset(0, 1).Interior.ColorIndex = 35

On Error GoTo 0

' Анализ положения ячейки

If (Not fTop And Not fLeft) Or _

(Not fBottom And Not fLeft And fRight) Or _

(Not fLeft And fRight) Or _

(Not fTop And fBottom) Then

' Ячейка подходит для начала слова

SetDigit intDigit, cell

intDigit = intDigit + 1

End If

End If

Next intCol

Next intRow

End Sub

Sub SetDigit(intDigit As Integer, cell As Range)

' Вставка цифры intDigit в ячейку, заданную параметром cell

cell.Value = intDigit

' Изменение настроек шрифта так, чтобы было похоже _

на настоящий кроссворд

' Маленький размер шрифта

cell.Font.Size = 6

' Выравнивание текста по левому верхнему углу ячейки

cell.HorizontalAlignment = xlLeft

cell.VerticalAlignment = xlTop

End Sub

Sub ToPrint()

' Удаление цветовой подсветки кроссворда

Cells.Interior.ColorIndex = xlNone

End Sub

Sub ToNumber()

' Закрытие первой формы и переход ко второй

UserForm1.Hide

UserForm2.Show

End Sub

Листинг 5.1 состоит из девяти макросов (семь первых можно запускать вручную):

• DrowCrosswordGrid – рисует сетку кроссворда для выделенных ячеек;

• Clear – удаляет кроссворд с рабочего листа;

• Clear Grid – удаляет рамку кроссворда в выделенных ячейках;

• AutoNumber – записывает номера в ячейки кроссворда;

• DisplayGrid – показывает сетку рабочего листа;

• Hide Grid – убирает сетку рабочего листа;

• ToPrint – удаляет цветовую подсветку ячеек кроссворда;

• SetDigit – помещает нужное число в указанную ячейку (этот макрос используется макросом AutoNumber для записи номеров в ячейки);

• ToNumber – переход от основной формы ко второй форме (см. ниже).

Вызывать все эти макросы вручную довольно неудобно. Их можно запускать посредством элементов управления, которые можно поместить прямо на рабочий лист или на пользовательскую форму. О создании пользовательской формы рассказывается в следующем подразделе.

Для создания основной формы программы необходимо воспользоваться вкладкой Разработчик, отображение которой включается в настройках программы в разделе Основные с помощью флажка Показывать вкладку «Разработчик» на ленте. На данной вкладке нужно по обычным правилам создать форму, изображенную на рис. 5.1.

Рис. 5.1. Первая форма программы

К элементам формы привяжем макросы (все привязываемые макросы входят в состав кода, который приведен выше, и доступны в окне выбора макросов):

• переключатель Сетка присутствует– макрос DisplayGrid;

• переключатель Сетка на поле отсутствует – макрос HideGrid;

• кнопка Новый кроссворд – макрос Clear;

• кнопка Нарисовать рамку – макрос DrawCrasswordGrid;

• кнопка Стереть рамку – макрос ClearGrid;

• кнопка Дальше – макрос ToNumber.

Теперь аналогичным образом (с помощью вкладки Разработчик) создадим еще одну форму, которая показана на рис. 5.2.

К элементам данной формы привяжем следующие макросы (они также присутствуют в коде и доступны в окне выбора макросов):

• кнопка Автонумерация – макрос AutoNumber;

• кнопка Очистить все – макрос Clear;

• кнопка Вывести на печать – макрос ToPrint.

Следует отметить, что можно не создавать пользовательские формы, а размещать все элементы управления прямо на рабочем листе. Если так поступить, то кнопка Далее в первой (главной) форме становится ненужной.

Рис. 5.2. Вторая форма программы

Итак, у нас все готово для составления кроссвордов. О порядке использования программы рассказывается в следующем подразделе.

С помощью созданной программы можно быстро составлять и нумеровать сетку кроссворда. Рассмотрим конкретный пример.

На листе создадим несколько выделенных областей, соединив их между собой (рис. 5.3).

Рис. 5.3. Выделение нескольких областей

Теперь нажмем кнопку Нарисовать рамку – результат представлен на рис. 5.4.

Рис. 5.4. Рамка кроссворда

Нажимаем кнопку Дальше – будет отображена вторая форма программы (см. рис. 5.2). В этой форме следует нажать кнопку Автонумерация – в результате сетка кроссворда будет быстро пронумерована (рис. 5.5).

Теперь нажимаем кнопку Вывести на печать – и на листе отобразится готовая сетка кроссворда (рис. 5.6).

С помощью кнопки Очистить все с листа удаляется рамка кроссворда.

Рис. 5.5. Нумерация сетки кроссворда

Кнопка Стереть рамку, которая находится на главной форме, позволяет удалить всю рамку (для этого ее нужно выделить) либо ее выделенный фрагмент.

При нажатии кнопки Новый кроссворд удаляется все содержимое документа, после чего можно приступать к составлению нового кроссворда.

Рис. 5.6. Готовая сетка кроссворда

Игра «Минное поле»

Пользователям Windows известно, что в комплект поставки операционной системы входит несколько игр, в том числе Сапер. Однако не многие знают, что подобную игру можно создать самостоятельно в Excel, используя механизм макросов.

Игра «Минное поле», о которой рассказывается в данном разделе, во многом аналогична стандартной игре Сапер. Для создания игры необходимо написать несколько макросов, объединенных в два кода: первый код должен быть помещен в модуль того рабочего листа, на котором предполагается разместить игру, а второй – в стандартный модуль.

В модуль рабочего листа необходимо поместить такой код (листинг 5.2).

Листинг 5.2. Код в модуле рабочего листа

Sub Worksheet_SelectionChange(ByVal Target As Range)

Dim intCol As Integer, intRow As Integer

Dim intMinesAround As Integer

Dim fInGameField As Boolean

' Определим, попадает ли в игровое поле выделенная ячейка

fInGameField = (Target.Row >= 2) And (Target.Row <= 7) _

And (Target.Column >= 2) And (Target.Column <= 7)

' Обрабатываем выделение ячейки

If Target.Value = "*" And fInGameField Then

' Пользователь выделил ячейку с миной – покажем мину

Target.Font.Color = RGB(0, 0, 0)

Target.Interior.Color = RGB(255, 0, 0)

' Пользователь проиграл!

EndGame

ElseIf fInGameField Then

' Пользователь выделил пустую ячейку. Оформим эту ячейку

Target.Interior.Color = RGB(0, 0, 255)

Target.Font.Color = RGB(0, 255, 0)

Target.Font.Size = 16

' Подсчитаем количество мин рядом с ячейкой (вокруг ячейки)

For intCol = Target.Column – 1 To Target.Column + 1

For intRow = Target.Row – 1 To Target.Row + 1

If Target.Worksheet.Cells(intRow, intCol).Value =

"*" _

Then

' Нашли очередную мину

intMinesAround = intMinesAround + 1

End If

Next

Next

' Отображение количества мин

Target.Value = intMinesAround

End If

End Sub

Код, который должен находиться в стандартном модуле, выглядит следующим образом (листинг 5.3).

Листинг 5.3. Код в стандартном модуле

Sub NewGame()

' Начало новой игры

' Подготовим поле для игры

InitGame

Dim intRow As Integer, intCol As Integer

Dim intMinesCount As Integer ' Количество мин

' Расставляем мины (то есть в случайные ячейки помещаем _

значения "*" и делаем цвет шрифта таким же, как цвет _

фона этих ячеек)

For intMinesCount = 1 To 10

' Строка для мины (от 2 до 7)

intRow = Int((6 * Rnd) + 1) + 1

' Столбец для мины (от 2 до 7)

intCol = Int((6 * Rnd) + 1) + 1

' Ставим мину, если ячейка пустая

If Cells(intRow, intCol) <> "*" Then

Cells(intRow, intCol).Font.Color = _

Cells(intRow, intCol).Interior.Color

Cells(intRow, intCol).Value = "*"

Else

' В данной ячейке мина есть – продолжим поиск ячеек

intMinesCount = intMinesCount – 1

End If

Next

' Вывод информации о количестве мин в строку состояния

Application.StatusBar = "Количество мин " & intMinesCount

End Sub

Sub InitGame()

' Раскраска (оформление) листа перед началом игры

Dim intRow As Integer, intCol As Integer

' Цвет фона всех ячеек

Cells.Interior.Color = RGB(0, 200, 75)

' Цвет шрифта всех ячеек

Cells.Font.Color = RGB(0, 0, 0)

' Размер шрифта

Cells.Font.Size = 18

' Все надписи – по центру

Cells.HorizontalAlignment = xlCenter

' Всем ячейкам игрового поля назначим особый цвет

For intRow = 2 To 7

For intCol = 2 To 7

Cells(intRow, intCol).Interior.Color = RGB(200, 200,

200)

Cells(intRow, intCol).Value = ""

Next

Next

End Sub

Sub EndGame()

' Завершение игры (поражение)

Dim intRow As Integer, intCol As Integer

' Покажем все мины. Для этого сделаем цвет шрифта всех ячеек _

черным (ведь во всех ячейках с минами "*" цвет шрифта и цвет _

заливки одинаковы)

For intRow = 2 To 7

For intCol = 2 To 7

If Cells(intRow, intCol).Value = "*" Then

Cells(intRow, intCol).Font.Color = RGB(0, 0, 0)

End If

Next

Next

MsgBox «Проигрыш»

End Sub

В данном примере рабочее поле игры будет расположено в диапазоне B2:G7. Для удобства поместим под ним кнопку вызова новой игры и привяжем к ней макрос NewGame (этот макрос будет доступен в окне выбора макросов после написания кода).

На рис. 5.7 показан интерфейс созданной игры «Минное поле».

Рис. 5.7. Игра «Минное поле»

Для запуска новой игры нужно нажать кнопку Начало игры или запустить макрос NewGame. Количество спрятанных мин будет показано в строке состояния. Ячейки на минном поле удобнее выбирать с помощью мыши. При выборе пустой ячейки в ней отобразится количество мин, расположенных рядом с данной ячейкой. При выборе ячейки с миной появится окно с сообщением Проигрыш (текст сообщения можно изменять по своему усмотрению путем внесения соответствующих корректировок в код игры).