Поиск  Пользователи  Правила  Войти
Форумы "Планета Excel" » Вопросы по Microsoft Excel
Страницы: 1
RSS
Подсчёт уникальных значений по критерию, Нужно оптимизировать (или предложить другой) код подсчёта уникальных значений по критерию
 
#1
26.05.2015 22:42:13
Доброго времени суток!
Нашел макрос и немного переделал его под свои нужды. Но беда в том, что он неплохо работает только на небольших объёмах. При 60 тыс строк - завершения работы макроса так и не дождался :( (прошли часы)...
Может быть кто-то сможет подсказать как можно ускорить выполнение макроса?
Ясно, что сильно тормозят циклы, но как без них обойтись, ума не приложу...

В данном примере для каждого товара (критерий - товар) нужно сосчитать количество уникальных продаж (критерий - № заказа) и количество уникальных покупателей (критерий Покупатель).
Например Товар1 встречается на 5-х строках, он фигурирует в 4-х уникальных продажах (заказах покупателя) и продавался 2-м покупателям.

Возможно надо использовать не коллекции?
Варианты со сводной не подходят. Возможно применить формулу если её как-то записать кодом.
Заранее спасибо.
 
 
 
#2
26.05.2015 22:47:02
Фильтр по товару
Копировать  Покупалелей
Вставить в другой диапазон (можно создать  лист, а после обработки убить)
Данные-Удалить_дубликаты
Имеем список уникальных покупателей, который можно перенести в другое место, загрузить в массив и т.д.
Повторить для номеров.

Естественно, все это прописать в коде.
 
 
 
#3
26.05.2015 22:56:30
vikttur, допустим из 60 тысяч строк 10 тысяч будут уникальные товары. Соответственно нужно будет 10 тысяч раз программно снять/убрать фильтр и в промежутках проводить вычисления. Я правильно понял Вашу мысль? Думал про это, но решил,что это будет более долгий путь.  
 
 
 
#4
26.05.2015 22:57:14
Ваш код медленный потому что работает в цикле с ячейками
попробуйте такой вариант:
Код
Sub ikki()
  Dim a(), b(), d1, d2, dt, i&
  Application.ScreenUpdating = False
  a = Range([a2], Cells(Rows.Count, "a").End(xlUp).Offset(, 2)).Value: ReDim b(1 To UBound(a), 1 To 2)
  Set d1 = CreateObject("scripting.dictionary")
  Set d2 = CreateObject("scripting.dictionary")
  For i = 1 To UBound(a)
    If d1.exists(a(i, 1)) Then Set dt = d1(a(i, 1)) Else Set dt = CreateObject("scripting.dictionary")
    dt(a(i, 2)) = 0&: Set d1(a(i, 1)) = dt
    If d2.exists(a(i, 1)) Then Set dt = d2(a(i, 1)) Else Set dt = CreateObject("scripting.dictionary")
    dt(a(i, 3)) = 0&: Set d2(a(i, 1)) = dt
  Next
  For i = 1 To UBound(a)
    b(i, 1) = d2(a(i, 1)).Count
    b(i, 2) = d1(a(i, 1)).Count
  Next
  [e2].Resize(UBound(b), 2).Value = b
End Sub
фрилансер Excel, VBA - контакты в профиле
"Совершенствоваться не обязательно. Выживание — дело добровольное." Э.Деминг
 
 
 
#5
26.05.2015 23:30:47
ikki,спасибо огромное! То что нужно. Ваш код примерно в 100 раз быстрее моего.
Пошёл учить матчасть...
 
 
 
Страницы: 1
Наверх