Приветствую! По работе разработал макрос для сметчиков и прочих сотрудниках, желающих быстро и легко получить список позиций, являющихся ценообразующими в своей группе по указанному пороговому % Решил закрепить темой на форуме - макрос, конечно, сильно другой (главное, что понятный и рабочий), но основная идея та же
Описание-алгоритм + скрин + код
Описание-алгоритм
0. Дана таблица сто столбцами (слева-направо): "ГРУППА" и "СУММА ПОЗИЦИИ" Разумеется, столбцов может быть больше, но для работы нам хватит только этих двух 1. Сортируем таблицу сначала по ГРУППЕ (по возрастанию), потом по СУММЕ (по убыванию) 2. Вычисляем СУММУ по ГРУППЕ для каждой строки таблицы 3. Вычисляем ДОЛЮ строки в СУММЕ по ГРУППЕ 4. Вычисляем НАКОПИТЕЛЬНУЮ ДОЛЮ путём наращивания/сложения ДОЛЕЙ внутри каждой ГРУППЫ 5. По НАКОПИТЕЛЬНОЙ ДОЛЕ вычисляем первые N строк сверху вниз, таким образом, чтобы последняя из отобранных строк была не меньшей (равной или больше) указанного итога, но только последняя из отобранных строк
Скрин
Код
Код
Option Explicit
Option Private Module
'===========================================================================================
Sub MainPartsOfSum()
Dim rng As Range, aBool() As Boolean
Dim arr, r&, s#, p#, flag As Boolean
Const threshold# = 0.8 ' порог
' сортировка умной таблицы на активном (на момент запуска макроса) листе по столбцам "ГР" (по возрастанию) и "СУММА" (по убыванию)
With ActiveSheet.ListObjects(1).Sort
.SortFields.Clear
.SortFields.Add Key:=Range("tbl[ГР]"), SortOn:=xlSortOnValues, Order:=xlAscending, DataOption:=xlSortNormal
.SortFields.Add Key:=Range("tbl[СУММА]"), SortOn:=xlSortOnValues, Order:=xlDescending, DataOption:=xlSortNormal
.Header = xlYes: .MatchCase = False: .Orientation = xlTopToBottom: .SortMethod = xlPinYin: .Apply
End With
' основная часть
Set rng = Range("A3:B19") ' для работы нам нужны только столбцы "ГРУППА" и "СУММА"
arr = rng.Value2 ' забираем диапазон в массив
ReDim aBool(1 To UBound(arr, 1), 1 To 1) ' создаём булевый массив-стобец отобранных строк для выгрузки на лист
aBool(1, 1) = True ' отмечаем строку в отобранных
s = WorksheetFunction.SumIf(rng.Columns(1), arr(1, 1), rng.Columns(2)) ' вычисляем СУММУ по ГРУППЕ
p = arr(1, 2) / s: If p - threshold > -0.0000000001 Then flag = True ' запоминаем ДОЛЮ и ставим флаг, если достигли порога
For r = 2 To UBound(arr, 1) ' основной цикл по строкам массива, начиная со 2ой
If arr(r, 1) <> arr(r - 1, 1) Then ' если это НОВАЯ группа …
flag = False: aBool(r, 1) = True ' сбрасываем флаг конца отбора и отмечаем строку в отобранных (первую строку НОВОЙ ГРУППЫ мы всегда берём)
s = WorksheetFunction.SumIf(rng.Columns(1), arr(r, 1), rng.Columns(2))
p = arr(r, 2) / s: If p - threshold > -0.0000000001 Then flag = True
Else ' если это НЕ НОВАЯ группа …
If Not flag Then ' если флаг конца отбора не стоит …
aBool(r, 1) = True: p = p + (arr(r, 2) / s) ' запоминаем строку и накапливаем ДОЛИ
If p - threshold > -0.0000000001 Then flag = True
End If
End If
Next r
Columns(rng.Column + 2).Insert
rng.Offset(0, 2).Resize(UBound(arr, 1), 1).Value2 = aBool
End Sub
'===========================================================================================
В файлеТоп ценообразующих.xlsb(23.05 КБ) также присутствует формульная реализация Какой вариант (формульный или макросный) использовать — решать вам, но, в любом случае, принцип работы знать нужно обязательно
Во всех делах очень полезно периодически ставить знак вопроса к тому, что вы с давних пор считали не требующим доказательств (Бертран Рассел) ►Благодарности сюда◄
Во всех делах очень полезно периодически ставить знак вопроса к тому, что вы с давних пор считали не требующим доказательств (Бертран Рассел) ►Благодарности сюда◄