M As Variant, Cand As
| Public Function IsMediana( M As Variant, Cand As Variant) As Integer 'Дан массив M и элемент Cand. В качестве результата возвращается 'разность между числом элементов массива M, больших и меньших Cand. Dim i As Integer, j As Integer Dim Pos As Integer, Neg As Integer Pos = 0: Neg = 0 'Анализ типа параметра M If TypeName(M) = "Range" Then For i = 1 To M.Rows.Count For j = 1 To M.Columns.Count If M.Cells(i, j) > Cand Then Pos = Pos + 1 ElseIf M.Cells(i, j) < Cand Then Neg = Neg + 1 End If Next j Next i IsMediana = Pos - Neg ElseIf TypeName(M) = "Variant()" Then 'TypeName is "Variant()" 'Это массив, но не совсем настоящий, для него не определены, 'например, функции границ: LBound, UBound. Dim Val As Variant For Each Val In M If Val > Cand Then Pos = Pos + 1 ElseIf Val < Cand Then Neg = Neg + 1 End If Next Val IsMediana = Pos - Neg ElseIf TypeName(M) = "Integer()" Then 'Это настоящий массив целых VBA, для которого 'определены функции границ. For i = LBound(M) To UBound(M) If M(i) > Cand Then Pos = Pos + 1 ElseIf M(i) < Cand Then Neg = Neg + 1 End If Next i IsMediana = Pos - Neg Else MsgBox ("При вызове функции:IsMediana(M,Cand)" _ & "- M не является массивом или объектом Range!") End If End Function |
| Пример 9.1. |
| Закрыть окно |
| Public Function IsMedianaForAll(Cand As Variant, ParamArray M() As Variant) As Integer ' Эта функция осуществляет те же вычисления, что и функция IsMediana 'Важное отличие состоит в том, что аргумент M может быть задан сложным объектом 'Range как объединение массивов. Dim i As Integer, j As Integer Dim Pos As Integer, Neg As Integer Pos = 0: Neg = 0 Dim Elem As Variant 'Теперь M - это массив параметров, а Elem - его элемент. For Each Elem In M 'Анализ типа параметра Elem If TypeName(Elem) = "Range" Then For i = 1 To Elem.Rows.Count For j = 1 To Elem.Columns.Count If Elem.Cells(i, j) > Cand Then Pos = Pos + 1 ElseIf Elem.Cells(i, j) < Cand Then Neg = Neg + 1 End If Next j Next i ElseIf TypeName(Elem) = "Variant()" Then 'TypeName is "Variant()" 'Это массив, но не совсем настоящий, для него не определены, 'например, функции границ: LBound, UBound. Dim Val As Variant For Each Val In Elem If Val > Cand Then Pos = Pos + 1 ElseIf Val < Cand Then Neg = Neg + 1 End If Next Val ElseIf TypeName(Elem) = "Integer()" Then 'Это настоящий массив целых VBA, для которого 'определены функции границ. For i = LBound(Elem) To UBound(Elem) If Elem(i) > Cand Then Pos = Pos + 1 ElseIf Elem(i) < Cand Then Neg = Neg + 1 End If Next i Else MsgBox ("При вызове IsMedianaForAll один из аргументов" _ & "не является массивом или объектом Range!") End If Next Elem IsMedianaForAll = Pos - Neg End Function |
| Пример 9.2. |
| Закрыть окно |
|
Public Sub TestRecursive() 'Сравнение по времени рекурсивной и нерекурсивной реализации факториала. Dim i As Long, Res As Long Dim Start As Single, Finish As Single 'Рекурсивное вычисление факториала Start = Timer For i = 1 To 100000 Res = Fact(12) Next i Finish = Timer Debug.Print "Время рекурсивных вычислений:", Finish - Start 'Нерекурсивное вычисление факториала Start = Timer For i = 1 To 100000 Res = Fact1(12) Next i Finish = Timer Debug.Print "Время нерекурсивных вычислений:", Finish - Start End Sub |
| Пример 9.3. |
| Закрыть окно |
|
Option Explicit 'Класс BinTree 'Бинарным будем называть дерево, у которого каждая вершина имеет 'одного или двух потомков, называемых левым и правым сыном (поддеревом). 'В дальнейшем будем полагать, что узел нашего дерева содержит 'информационное поле info и поле ключа - key. 'Деревом поиска (двоичным или лексикографическим деревом) будем называть 'бинарное дерево, в котором ключ каждой вершины больше ключа, хранящегося 'в корне левого поддерева, и меньше ключа, хранящегося в корне правого поддерева. 'Рассмотрим операции над деревом поиска: поиск, включение, удаление элементов 'и обход дерева. Все операции сохраняют структуру дерева поиска. Public root As TreeNode Public Sub PrefixOrder() 'Префиксный обход дерева (корень, левое поддерево, правое) If Not (root Is Nothing) Then With root Debug.Print "key: ",.key, "info: ",.info .left.PrefixOrder .right.PrefixOrder End With End If End Sub Public Sub InfixOrder() 'Инфиксный обход дерева (левое поддерево, корень, правое) If Not (root Is Nothing) Then With root .left.InfixOrder Debug.Print "key: ",.key, "info: ",.info .right.InfixOrder End With End If End Sub Public Sub PostfixOrder() 'Постфиксный обход дерева (левое поддерево, правое, корень) If Not (root Is Nothing) Then With root .left.PostfixOrder .right.PostfixOrder Debug.Print "key: ",.key, "info: ",.info End With End If End Sub Public Sub SearchAndInsert(key As String, info As String) 'Если в дереве есть узел с ключом key, 'то возвращается информация в этом узле - работает поиск 'Если такого узла нет, то создается новый узел и его поля 'заполняются информацией, - работает вставка. 'Вначале поиск If root Is Nothing Then ' элемент не найден и происходит вставка Set root = New TreeNode root.key = key: root.info = info ElseIf key < root.key Then 'Поиск в левом поддереве root.left.SearchAndInsert key, info ElseIf key > root.key Then 'Поиск в правом поддереве root.right.SearchAndInsert key, info Else 'Элемент найден - возвращается результат поиска info = root.info End If End Sub Public Sub DelInTree(key As String) 'Эта процедура позволяет удалить элемент дерева с заданным ключом 'Удаление с сохранением структуры дерева более сложная операция, 'чем вставка или поиск. Причина сложности в том, что при удалении 'элемента остаются два его потомка, которые необходимо корректно 'связать с оставшимися элементами, чтобы не нарушить структуру дерева поиска. 'В программе анализируются три случая: 'Удаляется лист дерева (нет потомков - нет проблем), 'Удаляется узел с одним потомком (потомок замещает удаленный узел), 'Есть два потомка. В этом случае узел может быть заменен одним из двух 'возможных кандидатов, не имеющих двух потомков. 'Кандидатами являются самый левый узел правого подддерева и 'самый правый узел левого поддерева. 'Мы производим удаление в левом поддереве. Dim q As TreeNode If root Is Nothing Then Debug.Print "Key is not found" ElseIf key < root.key Then 'Удаляем из левого поддерева root.left.DelInTree key ElseIf key > root.key Then 'Удаляем из правого поддерева root.right.DelInTree key Else 'Удаление узла Set q = root If q.right.root Is Nothing Then Set root = q.left.root ElseIf q.left.root Is Nothing Then Set root = q.right.root Else 'есть два потомка q.left.ReplaceAndDelete q End If Set q = Nothing End If End Sub Public Sub ReplaceAndDelete(q As TreeNode) 'Заменяет узел на самый правый If Not (root.right.root Is Nothing) Then root.right.ReplaceAndDelete q Else 'Найден самый правый q.key = root.key: q.info = root.info Set root = root.left.root End If End Sub |
| Пример 9.4. |
| Закрыть окно |
|
Public Sub WorkwithBinTree() Dim MyDict As New BinTree Dim englword As String, rusword As String 'Создание словаря MyDict.SearchAndInsert key:="dictionary", info:="словарь" MyDict.SearchAndInsert key:="hardware", info:="аппаратура, аппаратные средства" MyDict.SearchAndInsert key:="processor", info:="процессор" MyDict.SearchAndInsert key:="backup", info:="резервная копия" MyDict.SearchAndInsert key:="token", info:="лексема" MyDict.SearchAndInsert key:="file", info:="файл" MyDict.SearchAndInsert key:="compiler", info:="компилятор" MyDict.SearchAndInsert key:="account", info:="учетная запись" 'Обход словаря MyDict.PrefixOrder 'Поиск в словаре englword = "account": rusword = "" MyDict.SearchAndInsert key:=englword, info:=rusword Debug.Print englword, rusword 'Удаление из словаря MyDict.DelInTree englword englword = "hardware" MyDict.DelInTree englword 'Обход словаря MyDict.PrefixOrder End Sub |
| Пример 9.5. |
| Закрыть окно |
