Домашняя страница Undo Do New Save Карта сайта Обратная связь Поиск по форуму
МИР MS EXCEL - Гость.xls

Вход

Регистрация

Напомнить пароль

 

= Мир MS Excel/Подсчет суммы уникальных значений в отчете - Мир MS Excel

Регистрация · Логин: · Пароль: · · Забыли пароль?
  • Страница 1 из 1
  • 1
Модератор форума: _Boroda_, Manyasha, SLAVICK, китин  
Мир MS Excel » Вопросы и решения » Вопросы по VBA » Подсчет суммы уникальных значений в отчете (Макросы/Sub)
Подсчет суммы уникальных значений в отчете
parovoznik Дата: Вторник, 05.05.2020, 21:21 | Сообщение № 1
Группа: Проверенные
Ранг: Обитатель
Сообщений: 360
Репутация: 19 ±
Замечаний: 0% ±

Excel 2007
добрый вечер.
имеется таблица для формирования отчета за период в зависимости от дат и ряда параметров.
Отчет формируется,но нужна доп. таблица с отбором уникальных значений и суммированием данных. Уникальные значения отбираются, а как прописать код ,что бы автоматом прописывалось и суммироваание данных.
К сообщению приложен файл: Test_report.xlsm(361.2 Kb)
 
Ответить
Сообщениедобрый вечер.
имеется таблица для формирования отчета за период в зависимости от дат и ряда параметров.
Отчет формируется,но нужна доп. таблица с отбором уникальных значений и суммированием данных. Уникальные значения отбираются, а как прописать код ,что бы автоматом прописывалось и суммироваание данных.

Автор - parovoznik
Дата добавления - 05.05.2020 в 21:21
Michael_S Дата: Вторник, 05.05.2020, 21:55 | Сообщение № 2
Группа: Друзья
Ранг: Старожил
Сообщений: 1951
Репутация: 365 ±
Замечаний: 0% ±

Excel2016
[vba]
Код
Sub Extract_Unique()
    Dim vItem As Range, avArr, itArr, i&, k&
    With Sheets(1)
        With CreateObject("Scripting.Dictionary")
            For Each vItem In Range("B5", Cells(Rows.Count, 2).End(xlUp))
                .Item(vItem.Value) = .Item(vItem.Value) + vItem.Offset(0, 3).Value
            Next
            avArr = .keys
            itArr = .items
            k = .Count
            ReDim a(LBound(avArr) To UBound(avArr), 1)
            For i = LBound(avArr) To UBound(avArr)
                a(i, 0) = avArr(i)
                a(i, 1) = .Item(avArr(i))
            Next
        End With
    End With
    Sheets(2).Range("F5").Resize(k, 2) = a
End Sub
[/vba]
 
Ответить
Сообщение[vba]
Код
Sub Extract_Unique()
    Dim vItem As Range, avArr, itArr, i&, k&
    With Sheets(1)
        With CreateObject("Scripting.Dictionary")
            For Each vItem In Range("B5", Cells(Rows.Count, 2).End(xlUp))
                .Item(vItem.Value) = .Item(vItem.Value) + vItem.Offset(0, 3).Value
            Next
            avArr = .keys
            itArr = .items
            k = .Count
            ReDim a(LBound(avArr) To UBound(avArr), 1)
            For i = LBound(avArr) To UBound(avArr)
                a(i, 0) = avArr(i)
                a(i, 1) = .Item(avArr(i))
            Next
        End With
    End With
    Sheets(2).Range("F5").Resize(k, 2) = a
End Sub
[/vba]

Автор - Michael_S
Дата добавления - 05.05.2020 в 21:55
parovoznik Дата: Вторник, 05.05.2020, 22:12 | Сообщение № 3
Группа: Проверенные
Ранг: Обитатель
Сообщений: 360
Репутация: 19 ±
Замечаний: 0% ±

Excel 2007
Michael_S, благодарю. При подсчете сумма отображается 0,00
Прикладываю файл
К сообщению приложен файл: Test_report2.xlsm(360.6 Kb)
 
Ответить
СообщениеMichael_S, благодарю. При подсчете сумма отображается 0,00
Прикладываю файл

Автор - parovoznik
Дата добавления - 05.05.2020 в 22:12
gling Дата: Вторник, 05.05.2020, 22:26 | Сообщение № 4
Группа: Друзья
Ранг: Старожил
Сообщений: 2074
Репутация: 523 ±
Замечаний: 0% ±

2010
parovoznik, Здравствуйте. Попробуйте запустить макрос с листа Реестр.


ЯД-41001506838083

Сообщение отредактировал gling - Вторник, 05.05.2020, 22:28
 
Ответить
Сообщениеparovoznik, Здравствуйте. Попробуйте запустить макрос с листа Реестр.

Автор - gling
Дата добавления - 05.05.2020 в 22:26
Hugo Дата: Вторник, 05.05.2020, 22:37 | Сообщение № 5
Группа: Друзья
Ранг: Участник клуба
Сообщений: 2946
Репутация: 649 ±
Замечаний: 0% ±

Ну или нужно подправить смещение:
[vba]
Код
+ vItem.Offset(0, 1).Value
[/vba]
А если выполнять на первом листе - нужно править диапазон, B5 не годится.


excel@nxt.ru
webmoney: E265281470651 R418926282008 Z422237915069
 
Ответить
СообщениеНу или нужно подправить смещение:
[vba]
Код
+ vItem.Offset(0, 1).Value
[/vba]
А если выполнять на первом листе - нужно править диапазон, B5 не годится.

Автор - Hugo
Дата добавления - 05.05.2020 в 22:37
gling Дата: Вторник, 05.05.2020, 22:45 | Сообщение № 6
Группа: Друзья
Ранг: Старожил
Сообщений: 2074
Репутация: 523 ±
Замечаний: 0% ±

2010
нужно править диапазон, B5
Согласен, нужно заменить на B4.
Немного вник во весь процесс формирования отчета. Раз основная таблица создается через форму, то для Доп. таблицы наверно и лист нужно сменить на второй и vItem.Offset(0, 1). Возможно я не прав, так как не очень хороший специалист в написании макросов.
А на мой взгляд, эти таблицы можно было бы сделать сводными таблицами, не прибегая к написанию макросов.


ЯД-41001506838083

Сообщение отредактировал gling - Вторник, 05.05.2020, 23:15
 
Ответить
Сообщение
нужно править диапазон, B5
Согласен, нужно заменить на B4.
Немного вник во весь процесс формирования отчета. Раз основная таблица создается через форму, то для Доп. таблицы наверно и лист нужно сменить на второй и vItem.Offset(0, 1). Возможно я не прав, так как не очень хороший специалист в написании макросов.
А на мой взгляд, эти таблицы можно было бы сделать сводными таблицами, не прибегая к написанию макросов.

Автор - gling
Дата добавления - 05.05.2020 в 22:45
Hugo Дата: Вторник, 05.05.2020, 22:53 | Сообщение № 7
Группа: Друзья
Ранг: Участник клуба
Сообщений: 2946
Репутация: 649 ±
Замечаний: 0% ±

Очередное доказательство что наличие файла не исключает необходимости объяснить нормально задачу :)


excel@nxt.ru
webmoney: E265281470651 R418926282008 Z422237915069
 
Ответить
СообщениеОчередное доказательство что наличие файла не исключает необходимости объяснить нормально задачу :)

Автор - Hugo
Дата добавления - 05.05.2020 в 22:53
Michael_S Дата: Среда, 06.05.2020, 00:16 | Сообщение № 8
Группа: Друзья
Ранг: Старожил
Сообщений: 1951
Репутация: 365 ±
Замечаний: 0% ±

Excel2016
если считаем с первого листа, то:
[vba]
Код
Sub Extract_Unique()
    Dim vItem As Range, avArr, itArr, i&, k&, Rn As Range
    With Sheets(1)
            Set Rn = .Range("B4", .Cells(Rows.Count, 2).End(xlUp))
    End With
    With CreateObject("Scripting.Dictionary")
        For Each vItem In Rn
            .Item(vItem.Value) = .Item(vItem.Value) + vItem.Offset(0, 3).Value
        Next
        avArr = .keys
        itArr = .items
        k = .Count
        ReDim a(LBound(avArr) To UBound(avArr), 1)
        For i = LBound(avArr) To UBound(avArr)
            a(i, 0) = avArr(i)
            a(i, 1) = .Item(avArr(i))
        Next
    End With

Sheets(2).Range("F5").Resize(k, 2) = a
End Sub
[/vba]
Если со второго, то
[vba]
Код
Sub Extract_Unique_2()
    Dim vItem As Range, avArr, itArr, i&, k&, Rn As Range
    With Sheets(2)
            Set Rn = .Range("B5", .Cells(Rows.Count, 2).End(xlUp))
    End With
    With CreateObject("Scripting.Dictionary")
        For Each vItem In Rn
            .Item(vItem.Value) = .Item(vItem.Value) + vItem.Offset(0, 1).Value
        Next
        avArr = .keys
        itArr = .items
        k = .Count
        ReDim a(LBound(avArr) To UBound(avArr), 1)
        For i = LBound(avArr) To UBound(avArr)
            a(i, 0) = avArr(i)
            a(i, 1) = .Item(avArr(i))
        Next
    End With

Sheets(2).Range("F5").Resize(k, 2) = a
End Sub
[/vba]
какой лист активный - значения не имеет.
 
Ответить
Сообщениеесли считаем с первого листа, то:
[vba]
Код
Sub Extract_Unique()
    Dim vItem As Range, avArr, itArr, i&, k&, Rn As Range
    With Sheets(1)
            Set Rn = .Range("B4", .Cells(Rows.Count, 2).End(xlUp))
    End With
    With CreateObject("Scripting.Dictionary")
        For Each vItem In Rn
            .Item(vItem.Value) = .Item(vItem.Value) + vItem.Offset(0, 3).Value
        Next
        avArr = .keys
        itArr = .items
        k = .Count
        ReDim a(LBound(avArr) To UBound(avArr), 1)
        For i = LBound(avArr) To UBound(avArr)
            a(i, 0) = avArr(i)
            a(i, 1) = .Item(avArr(i))
        Next
    End With

Sheets(2).Range("F5").Resize(k, 2) = a
End Sub
[/vba]
Если со второго, то
[vba]
Код
Sub Extract_Unique_2()
    Dim vItem As Range, avArr, itArr, i&, k&, Rn As Range
    With Sheets(2)
            Set Rn = .Range("B5", .Cells(Rows.Count, 2).End(xlUp))
    End With
    With CreateObject("Scripting.Dictionary")
        For Each vItem In Rn
            .Item(vItem.Value) = .Item(vItem.Value) + vItem.Offset(0, 1).Value
        Next
        avArr = .keys
        itArr = .items
        k = .Count
        ReDim a(LBound(avArr) To UBound(avArr), 1)
        For i = LBound(avArr) To UBound(avArr)
            a(i, 0) = avArr(i)
            a(i, 1) = .Item(avArr(i))
        Next
    End With

Sheets(2).Range("F5").Resize(k, 2) = a
End Sub
[/vba]
какой лист активный - значения не имеет.

Автор - Michael_S
Дата добавления - 06.05.2020 в 00:16
parovoznik Дата: Среда, 06.05.2020, 07:05 | Сообщение № 9
Группа: Проверенные
Ранг: Обитатель
Сообщений: 360
Репутация: 19 ±
Замечаний: 0% ±

Excel 2007
Michael_S, все верно.Благодарю за помощь. hands
gling, за сводную таблицу я знаю иногда применяю на практике
HUGO ,извините,может некоректно описал задачу.Исправлюсь.
 
Ответить
СообщениеMichael_S, все верно.Благодарю за помощь. hands
gling, за сводную таблицу я знаю иногда применяю на практике
HUGO ,извините,может некоректно описал задачу.Исправлюсь.

Автор - parovoznik
Дата добавления - 06.05.2020 в 07:05
Michael_S Дата: Среда, 06.05.2020, 11:15 | Сообщение № 10
Группа: Друзья
Ранг: Старожил
Сообщений: 1951
Репутация: 365 ±
Замечаний: 0% ±

Excel2016
По просьбе parovoznik, через личку, код с небольшими комментариями:
[vba]
Код
Sub Extract_Unique_2() 'http://www.excelworld.ru/forum/10-44810-1
    Dim vItem As Range, avArr, itArr, i&, k&, Rn As Range
    Dim Itogo&
    With Sheets(2)
    Set Rn = .Range("B5", .Cells(Rows.Count, 2).End(xlUp))
    End With
    With CreateObject("Scripting.Dictionary") 'Инициируем словарь
        For Each vItem In Rn
'            проходим по диапазону номенклатуры
'            если элемента нет в словаре - создается пара ключ-значение
'            если есть, к значению прибавляем количество
            .Item(vItem.Value) = .Item(vItem.Value) + vItem.Offset(0, 1).Value
'            суммируем "Итого"
            Itogo = Itogo + vItem.Offset(0, 1).Value
        Next
        avArr = .keys 'массив  ключей
        itArr = .items 'массив значений
        k = .Count 'кол-во записей словаря
        ReDim a(LBound(avArr) To UBound(avArr), 1) 'доп. массив для вывода на лист
        For i = LBound(avArr) To UBound(avArr)
            a(i, 0) = avArr(i)
            a(i, 1) = .Item(avArr(i)) 'брать по ключу из словаря надежнее, чем из items
        Next
    End With
    With Sheets(2)
        .Range("F5", .Cells(Rows.Count, "G").End(xlUp)).Clear
        .Range("F5").Resize(k, 2) = a
        .Range("F5").Offset(k) = "Итого:"
        .Range("F5").Offset(k, 1) = Itogo
        .Range("F5").Resize(k + 1, 2).Borders.LineStyle = xlContinuous
    End With
End Sub
[/vba]

parovoznik, здесь, на сайте, есть хорошая статья по словарям и коллекциям: Dictionary и Collection - это совсем не сложно!


Сообщение отредактировал Michael_S - Среда, 06.05.2020, 11:16
 
Ответить
СообщениеПо просьбе parovoznik, через личку, код с небольшими комментариями:
[vba]
Код
Sub Extract_Unique_2() 'http://www.excelworld.ru/forum/10-44810-1
    Dim vItem As Range, avArr, itArr, i&, k&, Rn As Range
    Dim Itogo&
    With Sheets(2)
    Set Rn = .Range("B5", .Cells(Rows.Count, 2).End(xlUp))
    End With
    With CreateObject("Scripting.Dictionary") 'Инициируем словарь
        For Each vItem In Rn
'            проходим по диапазону номенклатуры
'            если элемента нет в словаре - создается пара ключ-значение
'            если есть, к значению прибавляем количество
            .Item(vItem.Value) = .Item(vItem.Value) + vItem.Offset(0, 1).Value
'            суммируем "Итого"
            Itogo = Itogo + vItem.Offset(0, 1).Value
        Next
        avArr = .keys 'массив  ключей
        itArr = .items 'массив значений
        k = .Count 'кол-во записей словаря
        ReDim a(LBound(avArr) To UBound(avArr), 1) 'доп. массив для вывода на лист
        For i = LBound(avArr) To UBound(avArr)
            a(i, 0) = avArr(i)
            a(i, 1) = .Item(avArr(i)) 'брать по ключу из словаря надежнее, чем из items
        Next
    End With
    With Sheets(2)
        .Range("F5", .Cells(Rows.Count, "G").End(xlUp)).Clear
        .Range("F5").Resize(k, 2) = a
        .Range("F5").Offset(k) = "Итого:"
        .Range("F5").Offset(k, 1) = Itogo
        .Range("F5").Resize(k + 1, 2).Borders.LineStyle = xlContinuous
    End With
End Sub
[/vba]

parovoznik, здесь, на сайте, есть хорошая статья по словарям и коллекциям: Dictionary и Collection - это совсем не сложно!

Автор - Michael_S
Дата добавления - 06.05.2020 в 11:15
parovoznik Дата: Среда, 06.05.2020, 12:02 | Сообщение № 11
Группа: Проверенные
Ранг: Обитатель
Сообщений: 360
Репутация: 19 ±
Замечаний: 0% ±

Excel 2007
Michael_S, здорово. Благодарю . :) Буду изучать.
 
Ответить
СообщениеMichael_S, здорово. Благодарю . :) Буду изучать.

Автор - parovoznik
Дата добавления - 06.05.2020 в 12:02
Мир MS Excel » Вопросы и решения » Вопросы по VBA » Подсчет суммы уникальных значений в отчете (Макросы/Sub)
  • Страница 1 из 1
  • 1
Поиск:

Яндекс цитирования
© 2010-2020 · Дизайн: MichaelCH · Хостинг от uCoz · При использовании материалов сайта, ссылка на www.excelworld.ru обязательна!