Функция НОД (наибольший общий делитель) на VBA

Ниже представлен аналог встроенной в Excel 2007 функции НОД (наибольший общий делитель), реализованный средствами VBA в Excel

В прикреплённом файле обратите внимание на формулы в синих и зелёных ячейках - как видите, результаты работы функций (встроенной, и пользовательской) полностью совпадают.

Использовать VBA-аналог функции НОД можно по-разному - как задавая в качестве параметра непрерывный диапазон ячеек, так и перечисляя значения (или ссылки на ячейки) через точку с запятой:

=NOD(A3:B4;B5:C6;B8)
=NOD(A4;B4;72)
=NOD(8;12;2;;6)
=NOD(A6:B7;B9:C10)
=NOD(A8:D8)
=NOD(A9;B11:C13)
=NOD(A9:B10;B11:C12;B14)
=NOD(B6;A6;B10;D10)

Внимание! Функция НОД появилась только в Excel 2007 - поэтому при открытии примера в Excel 2003 (и более ранних версиях) будет работать только пользовательская функция, а встроенная выдаст ошибку #ИМЯ!

Function NOD(ParamArray args() As Variant)
    ' в качестве параметра получает список диапазонов ячеек произвольного размера
    ' возвращает НОД (наибольший общий делитель) чисел из диапазонов-аргументов
    ' По сути, является аналогом функции НОД из Excel2007

    Application.Volatile True    ' автопересчёт при изменениях на листе
    Dim ra As Range, cell As Range: On Error Resume Next
    Dim coll As New Collection    ' коллекция для уникальных чисел из списка параметров

    For Index = LBound(args) To UBound(args)    ' перебираем все диапазоны ячеек
        If Not IsMissing(args(Index)) Then    ' если очередной аргумент присутствует

            If TypeName(args(Index)) = "Range" Then    ' если аргумент - диапазон ячеек
                For Each cell In args(Index).Cells    ' перебираем все ячейки в диапазоне
                    num = Fix(Val(cell.Value))    ' отбрасываем дробную часть числа, если не ноль
                    If num > 0 Then coll.Add num, CStr(num)    ' добавляем в коллекцию
                    ' если в ячейке - не число, то возвращаем ошибку #ЗНАЧ!
                    If Not IsNumeric(cell.Value) Then NOD = CVErr(1): Exit Function
                    If num < 0 Then NOD = CVErr(2036): Exit Function    ' возвращаем ошибку #ЧИСЛО!
                Next cell
 
            ElseIf IsNumeric(args(Index)) Then    ' если аргумент - число
                num = Fix(Val(args(Index)))    ' отбрасываем дробную часть числа
                If num > 0 Then coll.Add num, CStr(num)    ' добавляем в коллекцию, если не ноль
                ' если аргумент - не число, то возвращаем ошибку #ЗНАЧ!
                If Not IsNumeric(args(Index)) Then NOD = CVErr(1): Exit Function
                If num < 0 Then NOD = CVErr(2036): Exit Function    ' возвращаем ошибку #ЧИСЛО!
            End If
        End If
    Next Index
 
    ' алгоритм взят отсюда:   programmersforum.ru/showpost.php?p=178157&postcount=17
    Dim G As Long: G = coll(1): NOD = G
    If coll.Count = 1 Then Exit Function
    For i = 2 To coll.Count
        G = GCD(IIf(G < coll(i), G, coll(i)), IIf(G < coll(i), coll(i), G))
    Next
    NOD = G
End Function
 
Function GCD(a As Long, b As Long) As Long
    ' используется рекурсивный вызов
    Dim d As Long
    d = b Mod a
    If d = 0 Then GCD = a Else GCD = GCD(d, a)
End Function

Вложения:
NOD.xls40.5 КБ

Комментарии

Отправить комментарий

Содержание этого поля является приватным и не предназначено к показу.
CAPTCHA
Подтвердите, пожалуйста, что вы - человек:
         _  __  ___          _         
__ __ | |/ / |_ _| ___ | | __ _
\ \/ / | ' / | | / __| | | / _` |
> < | . \ | | | (__ | | | (_| |
/_/\_\ |_|\_\ |___| \___| |_| \__,_|
Введите код, изображенный в стиле ASCII-арт.

Не получается применить макрос? Не удаётся изменить код под свои нужды?

Оформите заказ у нас на сайте, не забыв прикрепить примеры файлов, и описать, что и как должно работать.