добрый вечер. имеется таблица для формирования отчета за период в зависимости от дат и ряда параметров. Отчет формируется,но нужна доп. таблица с отбором уникальных значений и суммированием данных. Уникальные значения отбираются, а как прописать код ,что бы автоматом прописывалось и суммироваание данных.
добрый вечер. имеется таблица для формирования отчета за период в зависимости от дат и ряда параметров. Отчет формируется,но нужна доп. таблица с отбором уникальных значений и суммированием данных. Уникальные значения отбираются, а как прописать код ,что бы автоматом прописывалось и суммироваание данных.parovoznik
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
Согласен, нужно заменить на B4. Немного вник во весь процесс формирования отчета. Раз основная таблица создается через форму, то для Доп. таблицы наверно и лист нужно сменить на второй и vItem.Offset(0, 1). Возможно я не прав, так как не очень хороший специалист в написании макросов. А на мой взгляд, эти таблицы можно было бы сделать сводными таблицами, не прибегая к написанию макросов.
Согласен, нужно заменить на B4. Немного вник во весь процесс формирования отчета. Раз основная таблица создается через форму, то для Доп. таблицы наверно и лист нужно сменить на второй и vItem.Offset(0, 1). Возможно я не прав, так как не очень хороший специалист в написании макросов. А на мой взгляд, эти таблицы можно было бы сделать сводными таблицами, не прибегая к написанию макросов.gling
ЯД-41001506838083
Сообщение отредактировал gling - Вторник, 05.05.2020, 23:15
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
Michael_S, все верно.Благодарю за помощь. gling, за сводную таблицу я знаю иногда применяю на практике HUGO ,извините,может некоректно описал задачу.Исправлюсь.
Michael_S, все верно.Благодарю за помощь. gling, за сводную таблицу я знаю иногда применяю на практике HUGO ,извините,может некоректно описал задачу.Исправлюсь.parovoznik
По просьбе 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
По просьбе 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
Вход
Регистрация
Напомнить пароль
Автосумма
Часто используемые
ВПР
ЕСЛИ
СУММЕСЛИ
Финансовые
Логические
Текстовые
Даты и времени 
Ссылки и массивы 
Математические
Другие функции
Проверка свойств и значений
Баз данных
Математические
Обработки массивов
Обработки строк
Преобразования типов данных 
Загрузки данных
Работы с файлами
Обработки системных параметров
Обработки цвета
Работы с датами и временем
Преобразования в системы счисления
Финансовые
