Найти в каждом столбце количество элементов, меньших среднего арифметического значения всех элементов

Sub Q()
 
Dim UserRange As Range
Dim wb As Workbook
 
Prompt = "выбор диапазона"
Title = "выбор диапазона"
 
Set wb = ActiveWorkbook
'отображение окна ввода данных
' выделяем диапазон для обработки
On Error Resume Next
Set UserRange = Range("A1").CurrentRegion
Set UserRange = Application.InputBox( _
  Prompt:=Prompt, _
  Title:=Title, _
  Default:=ActiveCell.Address, _
  Type:=8)
  UserRange.SelectionChange
On Error GoTo 0
 
' нахождение среднего
For Each j In UserRange
    i = i + 1
    A = A + j
Next j
 
SredZnach = A / i
 
 
' условие поиска необходимых значений
For Each j In UserRange
 
 If j < SredZnach Then
    MsgBox "Значение которое меньше среднего" & " " & j & " " & "Адрес ячейки" & " " & j.Address
 End If
 
Next j
 
 
End Sub

Function количество_элементов(ByVal Массив As Range)
Dim R, C
Dim M()
ReDim M(1 To Массив.Columns.Count)
For Each j In Массив.Cells
    i = i + 1
    A = A + j
Next j
SredZnach = A / i
For C = 1 To Массив.Columns.Count
    For R = 1 To Массив.Rows.Count
        If Массив(R, C).Value < SredZnach Then M(C) = M(C) + 1
    Next R
Next C
количество_элементов = M
End Function