Страницы: 1
RSS
Замена СчетЕсли при подсчёте количества звонков., Нужно придумать альтернативу формуле СЧЕТЕСЛИ
 
Доброго вечера!

Прошу не кидать камнями, так как знаю что подобные вопросы решают с помощью VBA, но там я не в зуб ногой.
Задача:
Есть список телефонных номеров(более 400К) и время звонка, каждому звонку нужно присвоить номер, если телефон первый раз попадается, то 1, если второй, то 2 и тп. Ранее файл считался с помощью =СЧЁТЕСЛИ($A$2:A3;A3), но формула очень тяжелая, и файл считается около часа. Может есть у кого идеи в обход VBA? Заранее спасибо
 
Цитата
wolfy36 написал:
идеи в обход VBA
в смысле vba не катит? а PQ?
Соблюдение правил форума не освобождает от модераторского произвола
 
Да VBA может и катит, только можно ли сделать чтобы только в одном столбце считалось vba а остальное было как и раньше? А что можно предпринять в PQ? Что то я не думал об этом
 
Цитата
wolfy36 написал:
что можно предпринять
будет понятно по файлу-примеру
Соблюдение правил форума не освобождает от модераторского произвола
 
Я так понимаю, в принципе можно задать это в vba, чтобы при подстановке данных, один из столбцом пересчитывал нумерацию...ну а кто сможет с этим помочь?)) прикладываю пример ID это уникальный номер в столбце с &&& нужны данные о порядковом номере
 
На VBA можно написать UDF :)
Т.е. можно забить сразу на весь миллион одну функцию, которая будет пересчитываться при замене данных.
Ну или протягивать её в любом диапазоне/файле, но на полмиллиона хлопотно тянуть...
 
wolfy36, дабы не закапывать преждевременно встроенные функции сделайте сперва доп столбец
=--E2  м попробуйте =СЧЁТЕСЛИ($E$1:E2;E2)
По вопросам из тем форума, личку не читаю.
 
так раньше так и было, я ж написал, ток на 400к контактов, очень долгий пересчет.
 
Цитата
Hugo написал:
На VBA можно написать UDF Т.е. можно забить сразу на весь миллион одну функцию, которая будет пересчитываться при замене данных.
А поможете?
 
Потестируйте.
Я тут в примере пару ID поменял, ну чтоб было вообще что считать.
P.S. Работает только на Винде! Для Мака нужно код чуть менять - нет у них словаря...
Изменено: Hugo - 24.09.2019 21:05:18
 
)) Ну считает, только теперь не понимаю как перенести это, простите за глупость
 
Я же написал - выделяете диапазон, и вводите массивно функцию. Как вводить - https://www.planetaexcel.ru/techniques/2/91/
См. пример 1 пункт 6.
А ну и конечно код из модуля нужно скопировать или в тот файл где будете применять, или в надстройку, или в любой открытый в фоне файл, но тогда синтаксис будет с указанием файла - вводите применяя мастер функций.
Изменено: Hugo - 24.09.2019 21:11:51
 
Спасибо, буду разбираться
 
Что же Вы постеснялись показать в файле повторяющиеся номера?
См. вариант макросом. Не знаю, сколько займёт времени обработка 400 000 строк.
 
Цитата
Hugo написал:
Я тут в примере пару ID поменял
Минутку, а считать нужно ID? Разве не номера?
 
Цитата
wolfy36 написал:
так раньше так и было,
вот прям как я написал так и было ? Не верю.
По вопросам из тем форума, личку не читаю.
 
Цитата
Юрий М написал:
инутку, а считать нужно ID? Разве не номера?
Смысл вроде тот же, спасибо, посмотрю оба способа где будет удобнее.
 
Цитата
wolfy36 написал:
Смысл вроде тот же
Если по ID считать, то массив будет легче )
 
А мне без разницы что считать :)
 
На 1кк номеров справляется за 1,9 сек (только сортировка) на рабочем компе.
Из "Е" столбца выбирает номера телефонов, превращает их в числа, сортирует, считает дубли, выгружает в столбец "I" список повторов.
Код
Type mDbl: d As Double: End Type
Type bArr: b(7) As Byte: End Type

Sub Idx()
Dim Arr(), qq(), aa&(), a&, b&, c&
With ActiveSheet
  a = .Cells(.Rows.Count, "E").End(xlUp).Row
  Arr = .Range("E2:E" & a).Value: ReDim qq(1 To UBound(Arr), 1 To 1)
  For a = 1 To UBound(Arr): Arr(a, 1) = CDbl(Mid$(Arr(a, 1), 2)): Next
  i = Timer
  NumSort Arr(), 1, aa()
  Debug.Print Timer - i
  For a = 1 To UBound(Arr) - 1
    b = 1: qq(a, 1) = b
    Do While Arr(aa(a), 1) = Arr(aa(a + 1), 1)
      qq(aa(a), 1) = b: b = b + 1: a = a + 1
      If a = UBound(Arr) Then Exit Do
    Loop
  Next: qq(aa(a), 1) = b
  .[I2].Resize(a, 1) = qq
End With
End Sub

Sub NumSort(Arr(), ByVal n&, aa&())
Dim bMap(), bb() As bArr, d As mDbl, m&, p&
Dim a&, b&, c&, dd&(), x&, xx&
'------------------------------------------------------
ReDim bb(1 To (UBound(Arr) - LBound(Arr) + 1)): ReDim dd(LBound(Arr) To UBound(Arr))
x = LBound(Arr) And 1 Xor 1
For a = LBound(Arr) To UBound(Arr)
  d.d = Arr(a, n): LSet bb(a + x) = d: dd(a) = a
  If bb(a + x).b(7) And 128 Then m = m + 1 Else p = p + 1
Next
For a = 3 To 7: ReDim bMap(0 To 255): c = 0
  For b = LBound(dd) To UBound(dd)
    bMap(bb(dd(b)).b(a)) = bMap(bb(dd(b)).b(a)) + 1
  Next
  For b = LBound(dd) To UBound(dd)
    If IsArray(bMap(bb(dd(b)).b(a))) Then
      bMap(bb(dd(b)).b(a))(0) = bMap(bb(dd(b)).b(a))(0) + 1: bMap(bb(dd(b)).b(a))(bMap(bb(dd(b)).b(a))(0)) = dd(b)
    Else: ReDim aa(0 To bMap(bb(dd(b)).b(a))): aa(0) = 1: aa(1) = dd(b): bMap(bb(dd(b)).b(a)) = aa
    End If
  Next: xx = LBound(dd)
  For b = 0 To 255
    If IsArray(bMap(b)) Then
      For c = 1 To bMap(b)(0): dd(xx) = bMap(b)(c): xx = xx + 1: Next
    End If
  Next
Next: Erase bMap: aa = dd: p = m + 1
For a = LBound(dd) To UBound(dd)
  If bb(dd(a)).b(7) And 128 Then aa(m) = dd(a): m = m - 1 Else: aa(p) = dd(a): p = p + 1
Next: dd = aa
For a = 2 To UBound(aa): x = a
  Do While Arr(dd(x - 1), n) > Arr(aa(a), n)
    dd(x) = dd(x - 1): x = x - 1
    If x = 1 Then Exit Do
  Loop
  dd(x) = aa(a)
Next: aa = dd: Erase dd
End Sub
Страницы: 1
Наверх