Найти среднее для ячеек с одинаковыми значениями

@deka6pb21 · Регистрация: 04.03.2013

Студворк — интернет-сервис помощи студентам

Найти среднее для ячеек с одинаковыми значениями

У меня в столбцах:
C-месяц
D-день
E-срок
F-мин
G- измерения.

У меня в строке D (дни), как вы видите на картинке, сначала семь 1, потом восемь 2, дальше восемь 3. Это значит что в первый день января было 8 измерений. В столбце G сами эти измерения. Так вот, мне нужно найти среднее этих измерений для каждого дня и вывести в столбец J допустим. Помогите пожалуйста. Вся сложность в том, что измерений может быть любое количество, но не больше 8.

Можно еще вот как, если измерений 8 то находим среднее и записываем в столбец J напротив, если другое количество, то в столбец J напротив пишем слово "НЕТ".
Заранее благодарен!

@Igor_Tr · 02.05.2013, 10:01

Не имея Вашу книгу для тестирования, писал, как проверку для моего воображения.

Процедура должна перелопатить сразу все Ваши листы и выдать результат (в районе "J") на каждом листе.
И еще. Если тормознется, кидайте сюда книгу (в 2003).
И еще. У Вас дюбляж. Название листа - месяц. И в столбик "С" - месяц, только номер. Так оно и надо?

Visual Basic
1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
Sub MeasurementOfParameters()
    Dim MonthNameLocal$, mSht As Object, shtName$
    Dim dict As Object, mKeys, mItems, counter&, i&, j&, a&, r&, mAVG#
    Dim shtARR(), tmpARR(), collecItms
        For q = 1 To 12
            MonthNameLocal(q) = MonthName(q)
        Next q
    counter = 0
    For Each mSht In ThisWorkbook.Sheets
        For i = LBound(MonthNameLocal) To UBound(MonthNameLocal)
            If InStr(1, UCase(mSht.Name), _
                        UCase(MonthNameLocal(i)), vbTextCompare) = 1 Then
                counter = counter + 1
                ReDim Preserve shtARR(counter)
                shtARR(counter) = mSht.Name
                Exit For
            End If
        Next 'i
    Next ' mSht
    Set dict = CreateObject("scripting.dictionary")
        dict.comparemode = 1
    For i = LBound(shtARR) To UBound(shtARR)
        With Sheets(shtARR(i))
            tmpARR = .Cells(3, 2).CurrentRegion.Value
                For j = LBound(tmpARR) To UBound(tmpARR)
                    If Not dict.exist(Trim(tmpARR(j, 1)) & ";;" & _
                                Trim(tmpARR(j, 2)) & _
                                                Trim(tmpARR(j, 3))) Then
                        dict.Item(Trim(tmpARR(j, 1)) & ";;" & _
                            Trim(tmpARR(j, 2)) & _
                                Trim(tmpARR(j, 3))) = _
                                    CDbl(Replace(tmpARR(j, 6), ",", ".", 1)) & ";;" & 1
                        Else
                            a = Split(dict.Item(Trim(tmpARR(j, 1)) & ";;" & _
                                Trim(tmpARR(j, 2)) & _
                                        Trim(tmpARR(j, 3))), ";;")(1) + 1
                            mAVG = Round((Split(dict.Item(Trim(tmpARR(j, 1)) & ";;" & _
                                Trim(tmpARR(j, 2)) & _
                                        Trim(tmpARR(j, 3))), ";;")(0) + _
                                                CDbl(Replace(tmpARR(j, 6), ",", ".", 1))) / a, 2)
                            dict.Item(Trim(tmpARR(j, 1)) & ";;" & _
                                Trim(tmpARR(j, 2)) & _
                                    Trim(tmpARR(j, 3))) = mAVG & ";;" & a
                    End If
                Next 'j
            r = .Cells(Rows.Count, 12).End(xlUp).Row + 1
            For Each mKeys In dict.keys
                With .Cells(r, 12)
                    .Offset(0, -3).Value = Split(mKeys, ";;")(0)
                    .Offset(0, -2).Value = Split(mKeys, ";;")(1)
                    .Offset(0, -1).Value = Split(mKeys, ";;")(2)
                    .Value = Split(dict.Item(mKeys), ";;")(0)
                End With
            Next 'mKeys
        End With
    Next 'i
End Sub

Добавлено через 12 минут
Уже вижу. Вот это:

r = .Cells(Rows.Count, 9).End(xlUp).Row + 1

нужно переставить сразу после этого (см.сразу, ниже):

For Each mKeys In dict.keys

Добавлено через 24 минуты
Еще выловил. Замените начало на это (по кол-ву строк 1 * 1):

Visual Basic
1
2
3
4
5
6
    Dim MonthNameLocal(), mSht As Object, shtName$
    Dim dict As Object, mKeys, mItems, counter&, i&, j&, a&, r&, mAVG#
    Dim shtARR(), tmpARR(), collecItms
        For i = 1 To 12
            MonthNameLocal(i) = MonthName(i)
        Next i

а перед выражением, которое я уже упоминал:

For Each mKeys In dict.keys

не мешает прописать очистку, что б можно было ганять до бесконечности:

.Range("i1:L" & Rows.Count).Delete

а так вроде все.

Добавлено через 15 часов 10 минут
Ну, извините. Вчера немного расслабились пивом.

Теперь посмотрел - пропустил еще ОБНУЛЕНИЕ словаря. И здесь слелал так, что бы отвязаться от Option Base. Пробуйте, но лучше бы мне все-таки пару Ваших листов с данными.

Visual Basic
1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
59
60
61
62
63
64
Sub MeasurementOfParameters()
    Dim MonthNameLocal(), mSht As Object, shtName$
    Dim dict As Object, mKeys, mItems, counter&, i&, j&, a&, r&, mAVG#
    Dim shtARR(), tmpARR(), collecItms
    ReDim MonthNameLocal(1 To 12)
        For i = 1 To 12
            MonthNameLocal(i) = MonthName(i)
        Next i
    counter = 0
    For Each mSht In ThisWorkbook.Sheets
        For i = 1 To UBound(MonthNameLocal)
            If InStr(1, UCase(mSht.Name), _
                        UCase(MonthNameLocal(i)), vbTextCompare) = 1 Then
                counter = counter + 1
                ReDim Preserve shtARR(counter)
                shtARR(counter) = mSht.Name
                Exit For
            End If
        Next 'i
    Next ' mSht
    Set dict = CreateObject("scripting.dictionary")
        dict.comparemode = 1
    For i = 1 To UBound(shtARR)
        With Sheets(shtARR(i))
            tmpARR = .Cells(3, 2).CurrentRegion.Value
                For j = LBound(tmpARR) To UBound(tmpARR)
                    If Not dict.exists(Trim(tmpARR(j, 1)) & ";;" & _
                                Trim(tmpARR(j, 2)) & ";;" & _
                                                Trim(tmpARR(j, 3))) Then
                        dict.Item(Trim(tmpARR(j, 1)) & ";;" & _
                            Trim(tmpARR(j, 2)) & ";;" & _
                                Trim(tmpARR(j, 3))) = _
                                    CDbl(Replace(tmpARR(j, 6), ",", ".", 1)) & ";;" & 1
                        Else
                            a = Split(dict.Item(Trim(tmpARR(j, 1)) & ";;" & _
                                Trim(tmpARR(j, 2)) & ";;" & _
                                        Trim(tmpARR(j, 3))), ";;")(1) + 1
                            mAVG = Round((Split(dict.Item(Trim(tmpARR(j, 1)) & ";;" & _
                                Trim(tmpARR(j, 2)) & ";;" & _
                                        Trim(tmpARR(j, 3))), ";;")(0) + _
                                                CDbl(Replace(tmpARR(j, 6), ",", ".", 1))) / a, 2)
                            dict.Item(Trim(tmpARR(j, 1)) & ";;" & _
                                Trim(tmpARR(j, 2)) & ";;" & _
                                    Trim(tmpARR(j, 3))) = mAVG & ";;" & a
                    End If
                Next 'j
            .Range("i1:L" & Rows.Count).Delete
            For Each mKeys In dict.keys
                r = .Cells(Rows.Count, 9).End(xlUp).Row + 1
                    With .Cells(r, 12)
                        .Offset(0, -3).Value = Split(mKeys, ";;")(0)
                        .Offset(0, -2).Value = shtARR(i)
                        .Offset(0, -1).Value = Split(mKeys, ";;")(2)
                        .Value = Split(dict.Item(mKeys), ";;")(0)
                    End With
            Next 'mKeys
            dict.RemoveAll
        End With
    Next 'i
    Erase tmpARR
    Erase shtARR
    Set dict = Nothing
    MsgBox Space(12) & "D O N E !"
End Sub

Скрипт · 02.05.2013, 11:49

Предложу свой вариант.
Если код будет медленно работать, то добавьте в код ещё отключение обновление монитора (команда "Application.ScreenUpdating").

Код

Visual Basic
1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
Sub Procedure_1()
 
    Dim myD() As Variant, myG() As Variant
    Dim myLastRow As Long
    Dim mySum As Double
    Dim myCount As Long
    Dim i As Long
    
    
    '1. Определяем последнюю строку с данными.
        'Действие аналогично действию:
        'делаем активной ячейку "D3" и нажимаем сочетание клавиш
        '"Ctrl + стрелка вниз".
    myLastRow = Range("D3").End(xlDown).Row
    
    '2. Помещаем данные из листа в VBA-массивы
        'для ускорения работы кода, т.к. с VBA-массивами
        'в некоторых случаях быстрее работать, чем с Excel-ячейками.
    myD() = Range("D1:D" & myLastRow).Value
    myG() = Range("G1:G" & myLastRow).Value
    
    '3. Двигаемся с конца в начало, т.к. это упрощает
        'написание кода.
    For i = myLastRow To 3 Step -1
        
        '4. Подсчитываем сумму.
        mySum = mySum + myG(i, 1)
        
        '5. Подсчитываем количество.
        myCount = myCount + 1
    
        'Если текущее число, не равно вышестоящему,
            'то значит повторы закончились.
        If myD(i, 1) <> myD(i - 1, 1) Then
        
            '6. Записываем в столбец "J" результат.
            Range("J" & i).Value = mySum / myCount
            
            '7. Подготавливаем переменные к следующему использованию.
            mySum = 0
            myCount = 0
            
        End If
        
    Next i
    
End Sub

@deka6pb21 · 02.05.2013, 12:08 **[ТС]**

13 ошибку выдает.
держите файл для наглядности
полностью файл не лезет, я оставил всего один лист (январь).

@deka6pb21 · 02.05.2013, 12:13 **[ТС]**

Скрипт
гениально, вроде все работает. Разобрался в коде. Все довольно просто. Спасибо большое)

@Igor_Tr · 02.05.2013, 15:42

Ну вот и результат. Если сравнить Ваш лист и скрин - увидите сами разницу (строка 2 пустая). А я применил .CurrentRegion. И еще. Дроби с запятой. Это правильно? У меня такое дает иногда сбой, только с точкой. Но это такое. Подкоректировал. Два варианта (мой и Скрипа) - лучьше всегда чем один.

Полученные результаты я не удалял, что б Вы видели, что будет на всех листах. Да и не надо удалять. Код при запуске всегда их все перезапишет. В макросе указана библиотека и как ее подключить.

@deka6pb21 · 02.05.2013, 16:14 **[ТС]**

Сообщение от Igor_Tr

Ну вот и результат. Если сравнить Ваш лист и скрин - увидите сами разницу (строка 2 пустая). А я применил .CurrentRegion. И еще. Дроби с запятой. Это правильно? У меня такое дает иногда сбой, только с точкой. Но это такое. Подкоректировал. Два варианта (мой и Скрипа) - лучьше всегда чем один.

Полученные результаты я не удалял, что б Вы видели, что будет на всех листах. Да и не надо удалять. Код при запуске всегда их все перезапишет. В макросе указана библиотека и как ее подключить.

В файле то что вы мне скинули, средние посчитаны неправильно. Пример: 1 января 2004г. У меня получается -5,7. У вас -1,28. Смотрим значения:
-2,8
-4,9
-5,8
-6,1
-6,4
-6,5
-7,6

Среднее значение -1,28 никак получится не может. То что вы мне в первый раз скинули у меня считает все отлично. Я его под себя маленько переделал и все ок.

@Igor_Tr · 02.05.2013, 16:22

Может быть. В таких вариантах как Ваш (где названия месяцев), у меня может быть заложена ошибка вызванная локализацией.

Поэтому просил несколько листов. И в последнем варианте убрал замену запятой на точку (тоже может выдавать ошибку). Меня бы больше интересовало время. Но главное - работает. Чье - второстепенно. Удачи.

@Igor_Tr · 02.05.2013, 17:15

ООООчень большая просьба!!!

Не говорите ничего моему пятикласнику! Он с меня неделю смеяться будет!!!!

@Igor_Tr · 02.05.2013, 17:21

Забыл. Строка 2108. Значение температуры отсутствует. Я включил игнорирование. Или нужно считать как 0?

Скрипт · 03.05.2013, 22:53

deka6pb21, для решения вашей задачи для одного месяца можно использовать средства самой программы "Excel".

Опишу на примере книги из сообщения #4 (Excel 2010):

сделайте активной ячейку "I1";
вкладка "Данные" - группа "Работа с данными" - "Консолидация";
"Функция": Среднее;
"Ссылка" - выделите диапазон "D1:G248";
"Добавить" - поставьте два флажка "подписи верхней строки" и "значения левого столбца" - "OK".

Сформируется таблица с данными по каждому дню.

Новые блоги и статьи Все статьи Все блоги /
Архитектура слоя интернета для сервера-слоя. Hrethgir 11.04.2026 В продолжение https:/ / www. cyberforum. ru/ blogs/ 223907/ 10860. html Знаешь что я подумал? Раз мы все источники пишем в голове ветки, то ничего не мешает добавить в голову такой источник, который сам. . .	Подстановка значения реквизита справочника в табличную часть документа Maks 10.04.2026 Алгоритм из решения ниже реализован на примере нетипового документа "ПланированиеПерсонала", разработанного в конфигурации КА2. Задача: при выборе сотрудника (справочник Сотрудники) в ТЧ документа. . .	Очистка реквизитов документа при копировании Maks 09.04.2026 Алгоритм из решения ниже применим как для типовых, так и для нетиповых документов на самых различных конфигурациях. Задача: при копировании документа очищать определенные реквизиты и табличную. . .	модель ЗдравоСохранения 8. Подготовка к разному выполнению заданий anaschu 08.04.2026 https:/ / github. com/ shumilovas/ med2. git main ветка * содержимое блока дэлэй из старой модели теперь внутри зайца новой модели 8ATzM_2aurI
Блокировка документа от изменений, если он открыт у другого пользователя Maks 08.04.2026 Алгоритм из решения ниже реализован на примере нетипового документа, разработанного в конфигурации КА2. Задача: запретить редактирование документа, если он открыт у другого пользователя. / / . . .	Система безопасности+живучести для сервера-слоя интернета (сети). Двойная привязка. Hrethgir 08.04.2026 Далее были размышления о системе безопасности. Сообщения с наклонным текстом - мои. А как нам будет можно проверить, что ссылка наша, а не подделана хулиганами, которая выбросит на другую ветку и. . .	Модель ЗдрввоСохранения 7: больше работников, больше ресурсов. anaschu 08.04.2026 работников и заданий может быть сколько угодно, но настроено всё так, что используется пока что только 20% kYBz3eJf3jQ	Дальние перспективы сервера - слоя сети с космологическим дизайном интефейса карты и логики. Hrethgir 07.04.2026 Дальнейшее ближайшее планирование вывело к размышлениям над дальними перспективами. И вот тут может быть даже будут нужны оценки специалистов, так как в дальних перспективах всё может очень сильно. . .

@deka6pb21 1 / 1 / 0 Регистрация: 04.03.2013 Сообщений: 42

	Найти среднее для ячеек с одинаковыми значениями 01.05.2013, 16:23. Показов 4703. Ответов 10 Метки нет (Все метки) У меня в столбцах: C-месяц D-день E-срок F-мин G- измерения. У меня в строке D (дни), как вы видите на картинке, сначала семь 1, потом восемь 2, дальше восемь 3. Это значит что в первый день января было 8 измерений. В столбце G сами эти измерения. Так вот, мне нужно найти среднее этих измерений для каждого дня и вывести в столбец J допустим. Помогите пожалуйста. Вся сложность в том, что измерений может быть любое количество, но не больше 8. Можно еще вот как, если измерений 8 то находим среднее и записываем в столбец J напротив, если другое количество, то в столбец J напротив пишем слово "НЕТ". Заранее благодарен! 0

@deka6pb21 1 / 1 / 0 Регистрация: 04.03.2013 Сообщений: 42
	02.05.2013, 12:13 [ТС]
	Скрипт гениально, вроде все работает. Разобрался в коде. Все довольно просто. Спасибо большое) 0

@Igor_Tr 4377 / 661 / 36 Регистрация: 17.01.2010 Сообщений: 2,134
	02.05.2013, 16:22
	Может быть. В таких вариантах как Ваш (где названия месяцев), у меня может быть заложена ошибка вызванная локализацией. Поэтому просил несколько листов. И в последнем варианте убрал замену запятой на точку (тоже может выдавать ошибку). Меня бы больше интересовало время. Но главное - работает. Чье - второстепенно. Удачи. 0

@Igor_Tr 4377 / 661 / 36 Регистрация: 17.01.2010 Сообщений: 2,134
	02.05.2013, 17:21
	Забыл. Строка 2108. Значение температуры отсутствует. Я включил игнорирование. Или нужно считать как 0? 0

Скрипт 5472 / 1150 / 50 Регистрация: 15.09.2012 Сообщений: 3,576
	03.05.2013, 22:53
	deka6pb21, для решения вашей задачи для одного месяца можно использовать средства самой программы "Excel". Опишу на примере книги из сообщения #4 (Excel 2010): сделайте активной ячейку "I1"; вкладка "Данные" - группа "Работа с данными" - "Консолидация"; "Функция": Среднее; "Ссылка" - выделите диапазон "D1:G248"; "Добавить" - поставьте два флажка "подписи верхней строки" и "значения левого столбца" - "OK". Сформируется таблица с данными по каждому дню. 0

Найти среднее для ячеек с одинаковыми значениями

Решение