Готовые макросы в vba excel, Миронов Глава Макросы 9

• Название: Готовые макросы в vba excel, Миронов Глава Макросы 9
• Дата: 06.02.2018
• Размер: 1.35 Mb.
• Имя файла: 33980_7d1642e70814394f108d07a8a2edd23e.doc
• Тип: Документы; #35930
• страница: 40 из 47

ГлаВА . РАЗНЫЕ ПРОГРАММЫ.

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

Листинг 6.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