Расчет суммы первых значений диапазона

Листинг 2.65. Функция dhNSum

Function dhNSum(ByVal intCount As Integer, _

 rgValues As Range) As Double

Dim i As Integer

Dim dblSum As Double

 

If intCount > rgValues.Count Then

' Задано количество элементов большее, чем есть _

  в переданном диапазоне

intCount = rgValues.Count

End If

' Расчет суммы первых intCount элементов

For i = 1 To intCount

dblSum = dblSum + rgValues(i)

Next i

' Возврат результата

dhNSum = dblSum

End Function

 

Размещение в ячейке электронных часов

Sub UpdateTime()

Dim varNextCall As Variant

' Записываем в ячейку текущее время

Cells(1, 1).Value = Now

' Записываем в varNextCall время, когда вызвать этот макрос _

в следующий раз (через 1 секунду)

varNextCall = TimeSerial(Hour(Now), Minute(Now), Second(Now) + 1)

' Уведомляем Excel в необходимости вызова макроса

Application.OnTime varNextCall, "UpdateTime"

End Sub

 «Будильник»

Sub Clock()

' Уведомляем Excel, что процедуру Alarm нужно вызвать в 20:55

Application.OnTime TimeValue("20:55:00"), "Alarm"

End Sub

Sub Alarm()

MsgBox "Пора ужинать!!!"

End Sub

Оформление верхней и нижней границ диапазона

Sub RangeBorder()

Dim rgRange As Range

Set rgRange = Range("B2:D5")

 

' Оформление верхней границы диапазона

With rgRange.Borders(xlEdgeTop)

.Weight = xlThick

.LineStyle = xlContinuous

.Color = RGB(0, 0, 255)

End With

' Оформление нижней границы диапазона

With rgRange.Borders(xlEdgeBottom)

.Weight = xlMedium

.LineStyle = xlDash

.Color = RGB(255, 0, 255)

End With

End Sub

Адрес активной ячейки

Sub Worksheet_SelectionChange(ByVal Target As Range)

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

MsgBox Target.Address() & vbCr & _

Target.Address(RowAbsolute:=False) & vbCr & _

Target.Address(ReferenceStyle:=xlR1C1) & vbCr & _

Target.Address(ReferenceStyle:=xlR1C1, _

RowAbsolute:=False, ColumnAbsolute:=False, _

RelativeTo:=Worksheets(1).Cells(2, 2))

End Sub

Координаты активной ячейки

ActiveCell.Row и ActiveCell.Column - покажут координаты активной ячейки.

Формула активной ячейки

s = Range("A3").Formula

Получение из ячейки формулы

Sub Test()

 With Application.Workbooks.Item("Test.xls")

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

Range("A2") = 2

Range("A3") = "=A2+2"

MsgBox Range("A3").Formula + " - " + Str(Range("A3").Value)

 End With

End Sub

Тип данных ячейки

Function dhCellType(rgRange As Range) As String

' Переходим к левой верхней ячейке, если rgRange - диапазон, _

а не одна ячейка

Set rgRange = rgRange.Range("A1")

' Определение типа значения в ячейке

Select Case True

Case IsEmpty(rgRange)

      ' Ячейка пуста

    dhCellType = "Пусто"

Case Application.IsText(rgRange)

    ' В ячейке текст

    dhCellType = "Текст"

Case Application.IsLogical(rgRange)

    ' В ячейке логическое значение (True или False)

    dhCellType = "Булево выражение"

Case Application.IsErr(rgRange)

    ' При вычислении значения в ячейке произошла ошибка

    dhCellType = "Ошибка"

Case IsDate(rgRange)

    ' В ячейке дата

    dhCellType = "Дата"

Case InStr(1, rgRange.Text, ":") <> 0

    ' В ячейке время

    dhCellType = "Время"

Case IsNumeric(rgRange)

    ' В ячейке числовое значение

    dhCellType = "Число"

End Select

End Function

 

Вывод адреса конца диапазона

Sub TestRange()

           Dim r As Range

           Set r = Range("rrrrr")

           MsgBox (r.Columns.End(xlUp).Address)

           MsgBox (r.Columns.End(xlDown).Address)

End Sub

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

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