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

Sub TypeOfSelection()

Dim rgSelUnion As Range ' Объединение выделенных областей

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

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

Dim strSelType As String ' Тип выделения (простой или _

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

Dim intBlockCount As Integer ' Количество блоков в выделении

Dim intCellCount As Long ' Общее количество выделенных ячеек

Dim intColCount As Integer ' Количество выделенных столбцов

Dim intRowCount As Long ' Количество выделенных строк

Dim intAreasCount As Integer ' Количество выделенных областей

Dim strCurSelType As String

Dim rgArea As Range

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

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

intAreasCount = Selection.Areas.Count

If intAreasCount = 1 Then

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

Else

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

End If

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

strSelType = dhGetAreaType(Selection.Areas(1))

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

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

Set rgSelUnion = Selection.Areas(1)

For Each rgArea In Selection.Areas

strCurSelType = dhGetAreaType(rgArea)

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

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

If strCurSelType <> strSelType Then

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

End If

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

If strCurSelType = "Block" Then

intBlockCount = intBlockCount + 1

End If

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

Set rgSelUnion = Union(rgSelUnion, rgArea)

Next rgArea

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

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

End Select

Next rgArea

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

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 = "Блок"

End If

End Function

Взять слово с 13 символа в ячейке

'берём значение ячейка А4 из Отчёта

iMonth = "за период с Июль 2 008 по Июль 2 008 "

'берём слово начиная с 13-го символа

iMonth = Evaluate("MID(TRIM(" & """" & iMonth & """" & "),13,(SEARCH("" "",TRIM(" & """" & iMonth & """" & "),13)-13))")

'вставляем это слово в книгу Ведомость

AddressSht.Range("A1") = iMonth

Создание изменяемого списка (таблица)

Sub Макрос2()

With ActiveSheet

.ListObjects.Add(xlSrcRange, .Range("$A$8:$AR$" & .Cells(Rows.Count, 1).End(xlUp).Row), , xlYes).Name = _

"Список1"

End With

End Sub

Проверка на пустое значение

IsNull(выражение) - проверка на пустое значение

Пересечение ячеек

Sub Test()

With ActiveWorkbook

Worksheets("Лист1").Activate

Dim Range1 As Range

Set Range1 = Range("A1:A8 A8:D8")

Range1.Value = "test"

End With

End Sub

Умножение выделенного диапазона на 2

Sub Test()

Dim cur_range As Range

With ActiveSheet

Set cur_range = Selection

cur_range.Activate

For x = 1 To cur_range.Rows.Count

For y = 1 To cur_range.Columns.Count

' значению ячейки присвоить значение умноженно на 2

cur_range(x, y) = cur_range(x, y).Value * 2

Next y

Next x

End With

End Sub

Одновременное умножение всех данных диапазона

Sub MultAllCells()

Dim dblMult As Double

Dim cell As Range

' Ввод коэффициента для умножения

dblMult = InputBox("Введите коэффициент, на который следует умножать")

' Умножение содержимого на введенный коэффициент

For Each cell In Selection

If IsNumeric(cell.Value) And cell.Value <> "" Then

' Умножаются только ячейки, содержащие числовые данные

cell.Value = cell.Value * dblMult

Else

MsgBox "В ячейке " & cell.Address & " нечисловое значение"

End If

Next

End Sub