Как найти среднее геометрическое vba

This will account for different types of inputs (I called the input arg_vNumbers instead of rs) and also only processes for inputs that are actually numbers, so it will ignore text, etc):

Public Function GEOMETRICMEAN(ByVal arg_vNumbers As Variant) As Variant

    Dim rConstants As Range
    Dim rFormulas As Range
    Dim rAdjusted As Range
    Dim vElement As Variant
    Dim lTotalElements As Long
    Dim dProductTotal As Double

    Select Case TypeName(arg_vNumbers)
        Case "Range"
            If arg_vNumbers.Rows.Count = arg_vNumbers.Parent.Rows.Count Then
                Set rAdjusted = Intersect(arg_vNumbers.Parent.UsedRange, arg_vNumbers)
            Else
                Set rAdjusted = arg_vNumbers
            End If
            On Error Resume Next
            Set rConstants = rAdjusted.SpecialCells(xlCellTypeConstants, xlNumbers)
            Set rFormulas = rAdjusted.SpecialCells(xlCellTypeFormulas, xlNumbers)
            On Error GoTo 0
            Select Case Abs((rConstants Is Nothing) + 2 * (rFormulas Is Nothing))
                Case 0: Set rAdjusted = Union(rConstants, rFormulas)
                Case 1: Set rAdjusted = rFormulas
                Case 2: Set rAdjusted = rConstants
                Case 3: GEOMETRICMEAN = CVErr(xlErrDiv0)
                        Exit Function
            End Select

            For Each vElement In rAdjusted
                If IsNumeric(vElement) And Len(vElement) > 0 Then
                    lTotalElements = lTotalElements + 1
                    If lTotalElements = 1 Then
                        dProductTotal = vElement
                    Else
                        dProductTotal = dProductTotal * vElement
                    End If
                End If
            Next vElement
            If lTotalElements > 0 Then
                GEOMETRICMEAN = dProductTotal ^ (1 / lTotalElements)
            Else
                GEOMETRICMEAN = CVErr(xlErrDiv0)
            End If

        Case "Variant()", "Collection", "Dictionary"
            For Each vElement In arg_vNumbers
                If IsNumeric(vElement) Then
                    lTotalElements = lTotalElements + 1
                    If lTotalElements = 1 Then
                        dProductTotal = vElement
                    Else
                        dProductTotal = dProductTotal * vElement
                    End If
                End If
            Next vElement
            If lTotalElements > 0 Then
                GEOMETRICMEAN = dProductTotal ^ (1 / lTotalElements)
            Else
                GEOMETRICMEAN = CVErr(xlErrDiv0)
            End If

        Case Else
            If IsNumeric(arg_vNumbers) Then
                GEOMETRICMEAN = arg_vNumbers
            Else
                GEOMETRICMEAN = CVErr(xlErrDiv0)
            End If

    End Select

End Function

The advantage to this is that it can also accept user defined arrays as part of a worksheet formula, for example: =GEOMETRICMEAN({2,8}) in addition to accepting a range of numbers. It can also accept VBA arrays, Collections and Dictionaries and will process only the numeric portions of those objects. If no numbers are included anywhere in the input, it returns a #DIV/0! error.

These allowances and error handling cause this UDF to behave pretty closely to how the built-in GEOMEAN function does.

Sub Primer()
 
    'Тип данных нужно указывать для каждой переменной.
    'Для массива нужно указывать круглые скобки.
    Dim A() As Integer
    Dim P As Integer, Min As Integer
    Dim N As Integer
    Dim R As Integer
    Dim i As Integer
    
    N = InputBox("Укажите, сколько чисел должно быть в массиве.")
    
    'Прежде чем работать с массивом
    'нужно указать его размер. Размер массива - это количество
    'элементов в массиве.
    'Размер массива задаётся с помощью ReDim.
    '1 To - используется, чтобы порядковый номер первого элемента массива
    'был один (по умолчанию ноль), чтобы было удобно писать код.
    ReDim A(1 To N)
    
    For i = 1 To N Step 1
        A(i) = InputBox("Введите число - элемент массива")
    Next i
    
    'Найти среднее геометрическое значение массива.
    P = 1
    For i = 1 To N Step 1
        P = P * A(i)
    Next i
    
    P = P ^ (1 / N)
    
    'Найти минимальный элемент массива.
    Min = A(1)
    For i = 2 To N Step 1
        If Min > A(i) Then Min = A(i)
    Next i
    
    'Найти разность минимального элемента массива и среднего геометрического.
    R = Min - P
    MsgBox (R)
    
End Sub

{quote}{login=The_Prist}{date=31.05.2010 09:12}{thema=Re: }{post}{quote}{login=kim}{date=31.05.2010 09:09}{thema=}{post}Дима, я имел ввиду вот это{/post}{/quote}А-а-а…стар я стал, подслеповат…  
Тады ой  

  Но предположу, что Кирилл специально воткнул туда 0, чтобы продемонстрировать обход ошибки в формуле.{/post}{/quote}  
Вот честное слово, The_Prist в самую точку попал

Алгоритмы
решения задач вычисления среднего
арифметического и среднего геометрического
элементов массива, удовлетворяющих
некоторому условию, представляют собой
комбинацию алгоритмов определения
количества элементов массива,
удовлетворяющих некоторому условию, и
вычисления суммы и произведения элементов
массива соответственно. Для вычисления
среднего арифметического необходимо
найти сумму и количество элементов,
удовлетворяющих поставленному условию.
А для вычисления среднего геометрического
надо найти произведение и количество
нужных элементов (определение среднего
геометрического нескольких чисел
приведено в разделе 6.1.3). Рассмотрим
особенности программной реализации
этих алгоритмов на примере задачи
вычисления среднего арифметического
четных элементов и среднего геометрического
нечетных элементов массива.

Объявляем
переменные, необходимые для решения
задачи. Переменные для хранения суммы
и произведения всегда будут иметь тот
же тип данных, что и элементы массива.

Dim summa, proiz As Integer

Переменные для хранения количества
четных (kol1)
и нечетных (kol2)
элементов массива, очевидно, будут иметь
целый тип.

Dim kol1, kol2 As Integer

Среднее арифметическое
получается в результате деления, поэтому
оно всегда имеет рациональный тип. То
же относится и к среднему геометрическому,
которое получается в результате
извлечения корня некоторой степени.

Dim arifm, geom As Single

Задаем начальные значения: для суммы –
ноль, для произведения – единица.

summa = 0

proiz = 1

До начала анализа элементов массива
оба количества полагаются равными нулю.

kol1 = 0

kol2 = 0

Организуем цикл для анализа элементов
массива. Элементы массива последовательно
пронумерованы от 0 до n.
Следовательно, счетчик цикла должен
изменяться в этом же диапазоне. Тогда
наi-м
шаге цикла мы будем обрабатывать элемент
массива с номеромi.

For i = 0 To n

На каждом шаге проверяем, является ли
очередной элемент массива четным числом.
Четные числа делятся на два без остатка.
Другими словами, для четных чисел остаток
при делении на два равен нулю.

If a(i) Mod 2 = 0 Then

Если
текущий элемент массива является четным
числом, то увеличиваем на единицу
количество четных элементов массива,
а к сумме добавляем значение элемента
массива.

kol1 += 1

summa += a(i)

Else

В противном случае, если элемент массива
является нечетным числом, мы увеличиваем
на единицу количество нечетных чисел,
а накопленное произведение умножаем
на значение текущего элемента массива.

kol2 += 1

proiz
*= a(i)

End If

Next

После окончания основного цикла
анализируем полученные результаты,
вычисляем значения среднего арифметического
и среднего геометрического, если это
возможно, и выводим ответы в окно списка.
Чтобы зрительно отделить исходные
данные от результатов вычислений, первым
делом выведем горизонтальную черту.

lstA.Items.Add(«——————————-«)

Анализируем количество четных чисел.

If kol1 = 0 Then

Если количество четных чисел равно
нулю, значит, в массиве нет ни одного
четного числа. В этом случае невозможно
вычислить их среднее арифметическое.
Поэтому вместо ответа надо вывести
поясняющий текст.

lstA.Items.Add(«Нет
четных»)

Else

В противном случае мы вычисляем среднее
арифметическое.

arifm = summa / kol1

Полученный результат мы выводим в окно
списка.

lstA.Items.Add(«Сред.
арифм. четных = » + _

Str(arifm))

End If

Теперь анализируем количество нечетных
чисел.

If kol2 = 0 Then

Если количество нечетных чисел равно
нулю, значит, в массиве нет ни одного
нечетного числа. В этом случае невозможно
вычислить их среднее арифметическое.
Поэтому вместо ответа надо вывести
поясняющий текст.

lstA.Items.Add(«Нет
нечетных»)

Else

Иначе мы анализируем знак подкоренного
выражения.

If proiz > 0 Then

Если произведение нечетных чисел
положительно, то мы можем вычислить их
среднее геометрическое без дополнительных
преобразований.

geom = proiz ^ (1 / kol2)

Полученное значение выводим в окно
списка.

lstA.Items.Add(«Сред.
геом. нечетных = » + _

Str(geom))

Else

В противном случае (если подкоренное
выражение отрицательное) мы должны
проверить четность степени корня.

If kol2 Mod 2 = 0 Then

Если требуется извлечь корень четной
степени, то задача вычисления среднего
геометрического не имеет решения, так
как извлечение корня четной степени из
отрицательного числа невозможно. Поэтому
вместо ответа выводим поясняющий текст.

lstA.Items.Add(«Невозможно
» + _

»
вычислить сред. геом.»)

Else

Иначе, если степень корня нечетная, то
для вычисления корня потребуется
составить арифметическое выражение. В
Visual Basic 2005 операция извлечения корня
произвольной степени определена только
для положительных подкоренных выражений.
Поэтому, когда необходимо извлечь корень
нечетной степени из отрицательного
числа, поступают следующим образом.
Корень извлекается из модуля подкоренного
выражения, а у полученного результата
знак меняется на противоположный.

geom
= -Math.Abs(proiz) ^ (1 / kol2)

Полученный результат выводим в окно
списка.

lstA.Items.Add(«Сред.
геом. » + _

«нечетных
= » + Str(geom))

End If

End If

End If

Полный
текст программы представлен в приложении
24. Примеры работы программы приведены
на рис. 39.

Рис. 39. Примеры работы программы
вычисления среднего арифметического
четных и среднего геометрического
нечетных элементов массива

Соседние файлы в предмете [НЕСОРТИРОВАННОЕ]

• #
• #
• #
• #
• #
• #
• #
• #
• #
• #
• #