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

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 - символ-разделитель.