Непосредственный ввод данных

Листинг 2.38.Ограничение возможных значений диапазона

Sub Worksheet_Change(ByVal Target As Excel.Range)

Dim rgInputRange As Range

Dim cell As Range

Dim strMessage As String

Dim varResult As Variant

' Диапазон, в котором контролируется ввод

Set rgInputRange = Range("A1:E10")

' Просмотр всех измененных ячеек и контроль ввода в тех, которые _

принадлежат заданному диапазону

ForEachcellInTarget

' Проверка принадлежности диапазону

If Union(cell, rgInputRange).Address = rgInputRange.Address Then

' Контроль правильности ввода

varResult = IsCellDataValid(cell)

If varResult = True Then

' Введено корректное значение

Exit Sub

Else

' Формирование и вывод сообщения об ошибке

strMessage = "Ячейка " & cell.Address(False, False) & ":" _

& vbCrLf & vbCrLf & varResult

MsgBox strMessage, vbCritical, "Неправильное значение"

' Очистка ввода

Application.EnableEvents = False

cell.ClearContents

cell.Activate

Application.EnableEvents = True

End If

End If

Next cell

End Sub

Function IsCellDataValid(cell As Range) As Variant

' Возвращает True, если в ячейку вводится целое число _

в диапазоне от 1 до 12. В противном случае выдается _

соответствующее сообщение

' Проверка, является ли содержимое ячейки числом

If Not WorksheetFunction.IsNumber(cell.Value) Then

IsCellDataValid = "Нечисловое значение"

Exit Function

End If

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

If Int(cell.Value) <> cell.Value Then

IsCellDataValid = "Введите целое число"

Exit Function

End If

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

If cell.Value < 1 Or cell.Value > 12 Then

IsCellDataValid = "Значение должно быть от 1 до 12"

Exit Function

End If

' В ячейку введено допустимое значение

IsCellDataValid = True

End Function

Последовательный ввод данных

Листинг 2.39.Последовательный ввод данных

SubStreamInput()

Dim strDate As String

Dim strSum As String

DimlngRowAsLong

' Ввод данных в цикле (повторяется до тех пор, пока пользователь _

не введет пустую строку или не нажмет "Отмена" в окне ввода)

Do

lngRow = Range("A65536").End(xlUp).Row + 1

' Ввод даты

strDate = InputBox("Вводим дату")

If strDate = "" Then Exit Sub

' Ввод выручки

strSum = InputBox("Вводим выручку")

If strSum = "" Then Exit Sub

' Запись данных в ячейки

Cells(lngRow, 1) =strDate

Cells(lngRow, 2) = strSum

Loop

End Sub

Быстрое выделение ячеек с отрицательными значениями

Листинг 2.40.Выделение отрицательных значений

SubNegSelect()

DimcellAsRange

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

которые содержат отрицательные значения

ForEachcellInSelection

If cell.Value < 0 Then

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

Else

cell.Interior.ColorIndex = xlNone

End If

Nextcell

EndSub

Получение информации о выделенном диапазоне

Листинг 2.41.Получение информации о выделенном диапазоне

SubTypeOfSelection()

DimrgSelUnionAsRange' Объединение выделенных областей

Dim strTitle As String ' Заголовок сообщения

Dim strMessage As String ' Текст сообщения

DimstrSelTypeAsString' Тип выделения (простой или _

множественный)

DimintBlockCountAsInteger' Количество блоков в выделении

DimintCellCountAsLong' Общее количество выделенных ячеек

DimintColCountAsInteger' Количество выделенных столбцов

DimintRowCountAsLong' Количество выделенных строк

DimintAreasCountAsInteger' Количество выделенных областей

Dim strCurSelType As String

Dim rgArea As Range

' Подсчет количества выделенных областей и определение типа выделения: _

простое (одна область) или сложное(несколько областей)

intAreasCount = Selection.Areas.Count

If intAreasCount = 1 Then

strTitle= "Простое выделение"

Else

strTitle= "Множественное выделение"

EndIf

' Определение типа выделения первой области

strSelType=dhGetAreaType(Selection.Areas(1))

' Создание объединения во избежание повторного учета _

пересекающихся участков выделенных диапазонов

SetrgSelUnion=Selection.Areas(1)

For Each rgArea In Selection.Areas

strCurSelType=dhGetAreaType(rgArea)

' Изменение надписи о типе всего выделения, если _

есть выделения различного типа

IfstrCurSelType<>strSelTypeThen

strSelType= "Множественный"

EndIf

' Определение количества блоков перед их добавлением в объединение

If strCurSelType = "Block" Then

intBlockCount = intBlockCount + 1

EndIf

' Добавление в объединение

Set rgSelUnion = Union(rgSelUnion, rgArea)

NextrgArea

' Просматриваются элементы созданного объединения

For Each rgArea In rgSelUnion.Areas

Select Case dhGetAreaType(rgArea)

Case "Строка"

intRowCount = intRowCount + rgArea.Rows.Count

Case "Столбец"

intColCount = intColCount + rgArea.Columns.Count

Case "Лист"

intColCount = intColCount + rgArea.Columns.Count

intRowCount = intRowCount + rgArea.Rows.Count

EndSelect

NextrgArea

' Определение количества неперекрывающихся ячеек

intCellCount=rgSelUnion.Count

' Формирование и вывод итогового сообщения

strMessage= "Тип выделения:" &vbTab&strSelType&vbCrLf& _

"Количество областей: " & vbTab&intAreasCount&vbCrLf& _

"Полных столбцов: " & vbTab&intColCount&vbCrLf& _

"Полных строк: " & vbTab&intRowCount&vbCrLf& _

"Блоков ячеек: " & vbTab&intBlockCount&vbCrLf& _

"Всего ячеек: " & vbTab & Format(intCellCount, "#,###")

MsgBox strMessage, vbInformation, strTitle

End Sub

Function dhGetAreaType(rgRangeArea As Range) As String

' Определение типа диапазона

If rgRangeArea.Count = Cells.Count Then

' Все ячейки рабочего листа

dhGetAreaType= "Лист"

ElseIf rgRangeArea.Cells.Count = 1 Then

' Одна ячейка

dhGetAreaType = "Ячейка"

ElseIf rgRangeArea.Rows.Count = Cells.Rows.Count Then

' Весь столбец

dhGetAreaType = "Столбец"

ElseIf rgRangeArea.Columns.Count = Cells.Columns.Count Then

' Вся строка

dhGetAreaType= "Строка"

Else

' Блок ячеек

dhGetAreaType= "Блок"

EndIf

EndFunction