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

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

 

Деление диапазона на 100

Sub Test23()

Dim iRange As Range

Dim kRange As Range

i = 1

j = 1

m = 5

n = 2

Set iRange = Range(Cells(i, j), Cells(m, n))

For Each kRange In iRange

kRange.Value = kRange.Value / 100

Next

End Sub

Возведение каждой ячейки диапазона в квадрат

Суммирование данных только видимых ячеек

Function СуммаВид(Диапазон) As Double

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

For Each Ячейка In Диапазон

' Анализ только видимых ячеек

If Not Ячейка.EntireRow.Hidden And Not _

  Ячейка.EntireColumn.Hidden Then

    ' При расчете учитываются только ячейки _

     с численными значениями

    If IsNumeric(Ячейка) = True Then

       СуммаВид = СуммаВид + Ячейка

    End If

End If

Next

End Function

Сумма ячеек с числовыми значениями

Sub CalculateSum()

Dim i As Integer

Dim intSum As Integer

' Расчет суммы ячеек столбца "A" (с первой по пятую)

For i = 1 To 5

If IsNumeric(Cells(i, 1)) Then

    intSum = intSum + Cells(i, 1)

End If

Next

MsgBox "Сумма ячеек: " & intSum

End Sub

 

При суммировании — курсор внутри диапазона

Function Сумма(Диапазон, АдресЯчейки) As Double

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

For Each Ячейка In Диапазон

' Проверка, чтобы в суммировании не участвовала _

  ячейка с формулой

If АдресЯчейки.Address <> Ячейка.Address Then

    ' В суммировании участвуют только ячейки _

     с численными значениями

    If IsNumeric(Ячейка) = True Then

       Сумма = Сумма + Ячейка

    End If

End If

Next

End Function

Начисление процентов в зависимости от суммы_1

Function dhCalculatePercent(lngSum As Long) As Double

' Процентные ставки (декларация констант)

Const dblRate1 As Double = 0.09

Const dblRate2 As Double = 0.11

 Const dblRate3 As Double = 0.15

' Граничные суммы вкладов (декларация констант)

Const intSum1 As Long = 5000

Const intSum2 As Long = 10000

 

' Возвращаем сумму, умноженную на соответствующую ставку

If lngSum < intSum1 Then

dhCalculatePercent = lngSum * dblRate1

ElseIf lngSum < intSum2 Then

dhCalculatePercent = lngSum * dblRate2

Else

dhCalculatePercent = lngSum * dblRate3

End If

End Function

Начисление процентов в зависимости от суммы_2

Function dhCalculatePercent(lngSum As Long) As Double

' Процентные ставки (декларация констант)

Const dblRate1 As Double = 0.09

Const dblRate2 As Double = 0.11

Const dblRate3 As Double = 0.15

' Граничные суммы вкладов (декларация констант)

Const intSum1 As Long = 5000

Const intSum2 As Long = 10000

 

' Возвращаем сумму, умноженную на соответствующую ставку

Select Case lngSum

Case Is < intSum1

    dhCalculatePercent = lngSum * dblRate1

Case Is < intSum2

    dhCalculatePercent = lngSum * dblRate2

Case Else

    dhCalculatePercent = lngSum * dblRate3

End Select

End Function

Начисление процентов в зависимости от суммы_3

Function dhCalculatePercent(Sales As Long, IsTemporal As Boolean) As Double

' Процентные ставки (декларация констант)

Const dblRate1 As Double = 0.09

Const dblRate2 As Double = 0.11

Const dblRate3 As Double = 0.15

Const dblAdd As Double = 1.1

' Граничные суммы

Const lngSum1 As Long = 5000

Const lngSum2 As Long = 10000

 

' Расчет суммы для выплаты (как обычно)

If Sales < lngSum1 Then

dhCalculatePercent = Sales * dblRate1

ElseIf Sales < lngSum2 Then

dhCalculatePercent = Sales * dblRate2

Else

dhCalculatePercent = Sales * dblRate3

End If

 

If IsTemporal Then

' Для сторонних вкладчиков - надбавка

dhCalculatePercent = dblAdd * dhCalculatePercent

End If

End Function

Сводный пример расчета комиссионного вознаграждения

Function dhCalculateCom(dblSales As Double) As Double

Const dblRate1 = 0.09

Const dblRate2 = 0.11

Const dblRate3 = 0.15

' Расчет комиссионных с продаж (без выслуги) в зависимости _

от суммы

Select Case dblSales

Case 0 To 4999.99: dhCalculateCom = dblSales * dblRate1

Case 5000 To 9999.99: dhCalculateCom = dblSales * dblRate2

Case Is >= 10000: dhCalculateCom = dblSales * dblRate3

End Select

End Function

 

Function dhCalculateCom2(dblSales As Double, intYears As Double) _

 As Double

Const dblRate1 = 0.09

Const dblRate2 = 0.11

Const dblRate3 = 0.15

 ' Расчет комиссионных с продаж (без учета выслуги лет) _

в зависимости от суммы

Select Case dblSales

Case 0 To 4999.99: dhCalculateCom2 = dblSales * dblRate1

Case 5000 To 9999.99: dhCalculateCom2 = dblSales * dblRate2

Case Is >= 10000: dhCalculateCom2 = dblSales * dblRate3

End Select

' Надбавка за выслугу лет

dhCalculateCom2 = dhCalculateCom2 + _

(dhCalculateCom2 * intYears / 100)

End Function

 

Sub ComCalculator()

Dim strMessage As String

Dim dblSales As Double

Dim ан As Integer

 

Calc:

' Отображение окна для ввода данных

dblSales = Val(InputBox("Сумма реализации:", _

"Расчет комиссионного вознаграждения"))

 

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

вознаграждения)

strMessage = "Объем продаж:" & vbTab & Format(dblSales, "$#,##0") & _

vbCrLf & "Сумма вознаграждения:" & vbTab & _

Format(dhCalculateCom(dblSales), "$#,##0") & _

vbCrLf & vbCrLf & "Считаем дальше?"

 

' Вывод окна с сообщением (о рассчитанной сумме и вопросом _

о продолжении расчетов)

If MsgBox(strMessage, vbYesNo, _

"Расчет комиссионного вознаграждения") = vbYes Then

' Продолжение расчетов

GoTo Calc

End If

End Sub

 

Движение по диапазону

Sub FullShach()

For Each c In Range(addressdiap)

If c.Value > yr1 Then

  c.Select

   With Selection.Interior

    .ColorIndex = 6

    .Pattern = xlSolid

   End With

  Selection.Font.ColorIndex = yrcolor1

  If c.Value > yr2 Then

  c.Select

  Selection.Font.ColorIndex = yrcolor2

       If c.Value > yr3 Then

       c.Select

       Selection.Font.ColorIndex = yrcolor3

       End If

  End If

End If

Next c

 

End Sub

Сдвиг от выделенной ячейки

Sub Test()

 Dim cur_range As Range

 Set cur_range = Range("A1")

 Set cur_range = cur_range.Offset(1, 0)

 Debug.Print cur_range.Address

End Sub

Перебор ячеек вниз по колонне

Sub beg()

Dim a As Boolean

Dim d As Double

Dim c As Range

a = False

Set c = Range(ActiveCell.Address)

c.Select

d = c.Value

c.Value = d

While (a = False)

ActiveCell.Offset(1, 0).Select

If (IsEmpty(ActiveCell.Value) = False) Then

Set c = Range(ActiveCell.Address)

c.Select

d = c.Value

c.Value = d

Else

a = False

End If

Wend

End Sub

Создание заливки диапазона

Sub FillRange()

' Заливка диапазона

With Range("B1:E10")

' Задаем узор - сетчатый

.Interior.Pattern = xlPatternChecker

' Цвет узора - синий

.Interior.PatternColor = RGB(0, 0, 255)

' Цвет ячейки - красный

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

End With

End Sub

Подбор параметра ячейки

Sub Макрос1()

' Сочетание клавиш: Ctrl+ф

Range("G5").GoalSeek Goal:=4, ChangingCell:=Range("G4")

End Sub

Разбиение диапазона

Function ExtractElement(Txt, n, Separator) As String ' Функция выдает n-ый элемент текстовой строки Txt, где ' символ Separator используется как разделитель   Dim Txt1 As String, TempElement As String Dim ElementCount As Integer, i As Integer Txt1 = Txt ' Если в качестве разделителя используется пробел, то убираем лишние ' и двойные пробелы If Separator = Chr(32) Then Txt1 = Application.Trim(Txt1) ' Добавляем разделитель в конец строки (если необходимо) If Right(Txt1, 1) <> Separator Then Txt1 = Txt1 & Separator ' Начальные значения ElementCount = 0 TempElement = "" ' Извлекаем элемент For i = 1 To Len(Txt1) If Mid(Txt1, i, 1) = Separator Then ElementCount = ElementCount + 1 If ElementCount = n Then ' Found it, so exit ExtractElement = TempElement Exit Function Else TempElement = "" End If Else TempElement = TempElement & Mid(Txt1, i, 1) End If Next i ExtractElement = "" End Function

Закройте редактор и вернитесь в Excel командой File - Close and return to Microsoft Excel.

Теперь в любой ячейке листа Вы можете использовать эту функцию через меню Вставка - Функция - категория Определенные пользователем, где в аргументах:

• Txt - ячейка с текстом, который надо разделить,
• n - порядковый номер извлекаемого элемента,
• Separator - символ-разделитель.

Объединение данных диапазона

Function Couple(Diapazon)

' Объединение данных, содержащихся в ячейках диапазона _

Diapazon (разделитель между значениями - пробел)

' iCell - текущая ячейка

For Each iCell In Diapazon

' Сцепляются данные только заполненных ячеек

If IsEmpty(iCell) <> True Then

    ' Добавление значения ячейки в выходную строку

    If Couple = "" Then

       Couple = iCell

    Else

       Couple = Couple & " " & iCell

    End If

End If

Next

End Function

Объединение данных диапазона_2

Function CoupleFormat(Diapazon)

' Объединение текстовых данных, содержащихся в ячейках _

диапазона Diapazon (разделитель между значениями - пробел)

' iCell - текущая ячейка

For Each iCell In Diapazon

' Сцепляются данные только заполненных ячеек

If IsEmpty(iCell) <> True Then

    ' Добавление текста ячейки в выходную строку

    If CoupleFormat = "" Then

       CoupleFormat = iCell.Text

    Else

       CoupleFormat = CoupleFormat & " " & iCell.Text

    End If

End If

Next

End Function

 

Узнать максимальную колонку или строку.

Sub Test()

 With ActiveSheet

Dim cur_range As Range

Set cur_range =.UsedRange

Debug.Print cur_range.Address

 End With

End Sub

Ограничение возможных значений диапазона

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")

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

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

For Each cell In Target

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

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

Тестирование скорости чтения и записи диапазонов

Sub TableSpeedTest()

Dim alngData() As Long   ' Массив с числами

Dim lngCount As Long     ' Количество элементов в массиве

Dim dtStart As Date      ' Хранит время (и даже дату) начала _

                             тестирования

Dim strArrayToTable As String ' Время записи в таблицу

Dim strTableToArray As String ' Время чтения из таблицы

Dim strMessage As String

Dim i As Long

 

' Подготовка диапазона ячеек

Range("A:A").ClearContents

 

' Ввод размера массива, формирование массива заданного размера

lngCount = InputBox("Введите количество элементов")

ReDim alngData(1 To lngCount)

' Заполнение массива данными

For i = 1 To lngCount

alngData(i) = i

Next i

 

' Перенос массива в таблицу

Application.ScreenUpdating = False

dtStart = Timer

For i = 1 To lngCount

Cells(i, 1) = i

Next i

strArrayToTable = Format(Timer - dtStart, "00:00")

 

' Чтение данных из таблицы обратно в массив

dtStart = Timer

For i = 1 To lngCount

alngData(i) = Cells(i, 1)

Next i

strTableToArray = Format(Timer - dtStart, "00:00")

Application.ScreenUpdating = True

 

' Вывод на экран результатов тестирования

strMessage = "Запись: " & strArrayToTable & vbCrLf & _

"Чтение: " & strTableToArray

MsgBox strMessage,, lngCount & " элементов"

End Sub

 

Открыть MsgBox при выборе ячейки

Private Sub Worksheet_SelectionChange(ByVal Target As Range)

If Target.Address = "$A$1" Then MsgBox "Hello world"

End Sub

Скрытие строки

Sub HideString()

Rows(2).Hidden = True

End Sub

Скрытие нескольких строк

Sub HideStrings()

Rows("3:5").Hidden = True

End Sub

Скрытие столбца

Sub HideCollumn()

Columns(2).Hidden = True

End Sub

Скрытие нескольких столбцов

Sub HideCollumns()

Columns("E:F").Hidden = True

End Sub

Скрытие строки по имени ячейки

Sub HideCell()

Range("Секрет").EntireRow.Hidden = True

End Sub

Скрытие нескольких строк по адресам ячеек

Sub HideCell()

Range("B3:D4").EntireRow.Hidden = True

End Sub

Скрытие столбца по имени ячейки

Sub HideCell()

Range("Секрет").EntireColumn.Hidden = True

End Sub

Скрытие нескольких столбцов по адресам ячеек

Sub HideCell()

Range("C2:D5").EntireColumn.Hidden = True

End Sub

Мигание ячейки

Sub BlinkingCell()

Static intCalls As Integer ' Счетчик количества миганий

 

' Если ячейка мигала менее 10 раз, то изменим _

в очередной раз ее цвет

If intCalls < 10 Then

intCalls = intCalls + 1

' Определение, какой цвет необходимо установить

If Range("A1").Interior.Color <> RGB(255, 0, 0) Then

    ' Цвет ячейки не красный, так что теперь назначим _

     именно красный цвет

    Range("A1").Interior.Color = RGB(255, 0, 0)

Else

    ' Назначим ячейке зеленый цвет

    Range("A1").Interior.Color = RGB(0, 255, 0)

End If

 

' Эту процедуру необходимо вызвать через 5 секунд

Application.OnTime Now + TimeValue("00:00:05"), "BlinkingCell"

Else

' Хватит мигать

Range("A1").Interior.ColorIndex = xlNone

intCalls = 0

End If

End Sub

 

 

 

Глава 4. Работа с примечаниями