Есть такой макрос:

Sub Macros()
'-------------begin----------
Dim LastValue As Single ' The value of last cell would be placed here
Dim I As Integer ' last row identificator
Dim Ifor As Integer ' common purpose variable
Dim J As Integer ' current counter - number of next going equal values
Dim tf As Boolean ' indicate whether previous cells value equal to current
Dim maxJ As Integer ' common counter - maximum number of next going equal values
I = ActiveCell.SpecialCells(xlLastCell).Row ' define last row
LastValue = Cells(I, 1).Value
J = 0 'initial values
tf = False ' ----
maxJ = 0 ' ----
For Ifor = 1 To I ' we are to path thru all rows in range
If Cells(Ifor, 1).Value = LastValue Then 'compare current value and the last one
If tf Then ' values are equal, here checked if previous value was also LastValue
J = J + 1 ' yes, add 1 to counter
Else
tf = True ' values equal but it's the first value to meet
maxJ = IIf(maxJ > J, maxJ, J) 'compare counters current and common,
' if number in current counter is more then in common one it
' become the value of common counter
J = 1 ' current counter is 1 again
End If
Else
tf = False ' values are not equal
End If
Next
maxJ = IIf(maxJ > J, maxJ, J)
Cells(I, 2).Value = CStr(LastValue) + "(" + Trim(Str(maxJ)) + ")" 'put result
'------------ end-------------
End Sub

Он делает такую хрень:

Например, есть часть столбца A1:A20,
в нем расположены числа сверху вниз от A1 до A7,
и выводиться на экран следующая запись:

"5 (3)", что значит 5-последнее значение, (3)-3 пятерки подряд

1
2
3
4
5
5
5

Но он работает только в столбце A, и считает только числовые значения, а диапзонов где его надо применить много.

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

	Post Attachments
	xl.JPG (10 views, 24,33 KB)

=МОДА(E14:E20) & " (" & СЧЁТЕСЛИ(E14:E20;МОДА(E14:E20))&")"

где E14:E20 ваш диапазон

P.S.

=МОДА(Данные) - ищет часто встречаемое число

=СЧЁТЕСЛИ(Данные;МОДА(Данные)) - сколько раз оно повторялось

Function myCount(iRange As Range) As String
    Dim iItem As Variant
    iItem = Range(Right(iRange.Address, 5)).Value
    myCount = iItem & " (" & Application.CountIf(iRange, iItem) & ")"
End Function

Function myCount(iRange As Range) As String 
 Dim iItem As Variant
 iItem = Range(Right(iRange.Address, 5)).Value
 myCount = iItem & " (" & Application.CountIf(iRange, iItem) & ")"
End Function

Выдает ошибку #ЗНАЧ, но вот такую штуку как раз и надо внедрить в вышеописанный макрос (и переделать в функцию)

А МОДА не подходит, делает не то ( должно определяться нижнее (текущее) значение, и так чтобы, считалось бы количество рядомстоящих одинаковых значений равных нижнему)

Function myCount(iRange As Excel.Range) As String
    Dim LastValue As Variant
    Dim J As Integer
    Dim tf As Boolean
    Dim maxJ As Integer
    Dim iCell As Range
    LastValue = Split(iRange.Address(False, False), ":")
    LastValue = LastValue(1)
    LastValue = Range(LastValue).Value
    J = 0
    tf = False
    maxJ = 0
    For Each iCell In iRange
        If iCell.Value = LastValue Then
            If tf Then
                J = J + 1
            Else
                tf = True
                maxJ = IIf(maxJ > J, maxJ, J)
                J = 1
            End If
        Else
            tf = False
        End If
    Next
    maxJ = IIf(maxJ > J, maxJ, J)
    myCount = CStr(LastValue) + " (" + Trim(Str(maxJ)) + ")"
End Function

P.S. когда хотите выложить код на форуме, пожалуйста, берите его в тэги

[.code]

.... ВАШ КОД...

[./code]

только без точек, которые я написал внутри квадратных скобок (они для того, чтобы вы увидели эти скобки сейчас)

Извиняюсь ,по ходу я нет так обьяснил что нужно сделать:

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

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

Function myCount(iRange As Excel.Range) As String
    Dim LastValue As Variant
    Dim J As Integer
    Dim tf As Boolean
    Dim maxJ As Integer
    Dim iCell As Range
    For Each iCell In iRange
        If iCell.Value = Empty Then Exit For
        LastValue = iCell.Value
    Next
    If LastValue = Empty Then
        myCount = "" 'или 0
        Exit Function
    End If
    J = 0
    tf = False
    maxJ = 0
    For Each iCell In iRange
        If iCell.Value = LastValue Then
            If tf Then
                J = J + 1
            Else
                tf = True
                maxJ = IIf(maxJ > J, maxJ, J)
                J = 1
            End If
        Else
            tf = False
        End If
    Next
    maxJ = IIf(maxJ > J, maxJ, J)
    myCount = CStr(LastValue) & " (" & Trim(Str(maxJ)) & ")"
End Function

P.S. если диапазон пуст - функция ничего не отобразит - т.е. будет пустая ячейка (но можно, чтобы она отобразила 0 - в коде есть комментарий)

P.P.S. у мя закончился интернет на работе, если что, смогу ответить только из дома после 9 вечера )