Поиск  Пользователи  Правила  Войти
Форумы "Планета Excel" » Вопросы по Microsoft Excel
Страницы: 1 2 След.
RSS
Счетесли с помощью vba
 
#1
01.06.2017 10:54:56
Добрый день, знатока своего дела.
Столкнулся я с такой сложностью, а именно есть огромная пелена данных и для определённых действий нужно посчитать количество повторов, если(счетесли(d15;d:d)>70;"да";"нет") справляется с задачей отлично, но вот проблема в том, что исходники бывают на 270 тысяч строк и из-за этого данная формула считает несколько часов.
Подскажите как можно ускорить весь процесс расчета? Ытался написать макрос но в vba я не силён.
Если вдруг повторил какую-то тему, то прошу прощения, я искал возможные решения и не нашёл
P.s ещё проблема в том, что файлов около 100 размеры у них от 2х МБ до 16МБ(в двоичной книге) и изменять их нельзя.
Изменено: Cold_sauce - 01.06.2017 11:19:11
 
 
 
#2
01.06.2017 10:59:42
Здравствуйте. Лучше в маленьком файле покажите что и как, а то считаете повторы, а результат ;"да";"нет"
 
 
 
#3
01.06.2017 11:01:37
Цитата
Cold_sauce написал: 16МБ(в двоичной книге)
Офф. 8-0 может стоит задуматься о другом инструменте (НЕ Excel) обработки таких объемов данных?
Согласие есть продукт при полном непротивлении сторон
 
 
 
#4
01.06.2017 11:12:18
К сожалению отправить файл не могу из-за того что сижу с телефона и интернет на работе закрыт, подсчитывается номер операции состоящий из 9цифр, но выгружается в текстовом формате.

другой инструмент к сожалению тоже не подходит ибо это требование работодателя.  
 
 
 
#5
01.06.2017 11:14:24
Cold_sauce, с какой целью пишете через 1-2 строки? Исправьте своё сообщение.

Цитата
Cold_sauce написал:
проблема в том, что файлов около 100 размеры у них от 2х МБ до 16МБ(в двоичной книге) и изменять их нельзя
Никто и не просит Ваши РАБОЧИЕ файлы - создайте небольшой файл-аналог с аналогичной структурой.
По вопросу: есть в VBA функция рабочего листа: WorksheetFunction.CountIf
Или забирайте диапазон в массив и прогоняйте циклом.
 
 
 
#6
01.06.2017 11:15:07
Что должно быть результатом работы макроса? Напишите обычными словами
Согласие есть продукт при полном непротивлении сторон
 
 
 
#7
01.06.2017 11:15:32
Цитата
Cold_sauce написал:
отправить файл не могу из-за того что сижу с телефона и интернет на работе закрыт
Тогда как проверите решение?
 
 
 
#8
01.06.2017 11:18:27
Результатом может быть все что угодно, это потребуется для дальнейших расчетов. Т.е можно даже количество повторов в столбце. Можно при условие больше 70 повторов да если истина нет если ложь.  
 
 
 
#9
01.06.2017 11:21:24
Юрий, я не считаю ваш вопрос по поводу проверки решения конструктивным, ибо перепечатать макрос или скопировать текст и отправить себе на раб почту можно и с телефона, а дальше внести
Изменено: Cold_sauce - 01.06.2017 11:22:11
 
 
 
#10
01.06.2017 11:21:49
Цитата
Sanja написал:
Что должно быть результатом работы макроса?
Цитата
Cold_sauce написал:
Результатом может быть все что угодно
Класс!!! )
 
 
 
#11
01.06.2017 11:25:47
Цитата
Cold_sauce написал: Результатом может быть все что угодно
Прикольно.Тогда Вам подойдет ЛЮБОЙ макрос
Согласие есть продукт при полном непротивлении сторон
 
 
 
#12
01.06.2017 11:28:43
Цитата
Cold_sauce написал:
Юрий, я не считаю ваш вопрос по поводу проверки решения конструктивным
Хорошо - на самом деле можно скопировать с телефона. Ну а как быть тем, кто собирается написать Вам макрос? Где его писать?
 
 
 
#13
01.06.2017 11:33:08
Юрий М, очень не люблю когда выдергивают куски из текста, т.к вы именно это и сделали когда цитировали "результатом может быть все что угодно", это промежуточный этап, который занимает огромное кол-во времени, и обойти его нельзя, Поэтому и попросил помочь.

Если макрос будет выводить кол-во повторов как и стандартная функция счётесли, то ок, добавлю ещё один столбец с с условием, если сразу с условием то любое значение при выполнение условия( 1,0 ; да,нет; true, false)
 
 
 
#14
01.06.2017 11:38:33
Да что же Вы пристали к "выдёргиванию"? Сами ведь выдернули из моих сообщений самое ненужное. В #5 я же ответил на Ваш вопрос по поводу СЧЁТЕСЛИ на VBA - конструктивно?
 
 
 
#15
01.06.2017 11:42:52
Код
Sub SumIfMacro()
With ActiveSheet
    lRow = .Cells(.Rows.Count, "D").End(xlUp).Row
    arrVal = .Range("D1:D" & lRow).Value  'диапазон от D1 до последней ячейки с данными в столбце D
    For I = 1 To UBound(arrVal)                
        If arrVal(I, 1) > 70 Then 'условие '>70'
            iSum = iSum + 1
        End If
    Next
    .Range("D" & lRow + 1) = iSum   'результат вставляется в столбец D, под данными
End With
End Sub
Согласие есть продукт при полном непротивлении сторон
 
 
 
#16
01.06.2017 11:43:23
Или:
Код
Sub Macro1()
Dim LastRow As Long, x As Long
    LastRow = Cells(Rows.Count, 4).End(xlUp).Row
    x = Application.WorksheetFunction.CountIf(Range(Cells(2, 4), Cells(LastRow, 4)), Cells(15, 4))
    If x > 70 Then
        MsgBox "Да"
    Else
        MsgBox "Нет"
    End If
End Sub
 
 
 
#17
01.06.2017 11:45:42

Код
Option Explicit
Sub znach_Count()
Dim ir As LongDim ishod As Range, iLastCell As Long, Cell As Range, iText As String, ischet As Long

iLastCell = Cells(13, 5).SpecialCells(xlLastCell).RowSet
 ishod = Range(Cells(14, 5), Cells(iLastCell, 5))
ir = 14
For Each Cell In iSource
  iText = Cells(ir, 5).Value  
  ischet = Application.WorksheetFunction.CountIf(iSource, iText)
  If ischet > 50 Then ischet = 1 Else iCount = 0
   Cells(ir, 77).Value = ischet
  ir = ir + 1
NextEnd Sub

Для примера вот макрос который считает и выдаёт то, что нужно, но при диапазоне в 270 тыс. Строк excel умер, точнее считал порядка полутора часов и так и не посчитал что нужно.
как превратить это в работу с массивом к сожалению не хватает ума.
Изменено: Cold_sauce - 01.06.2017 20:46:40
 
 
 
#18
01.06.2017 11:49:34
1. Код следует оформлять тегом - ищите такую кнопку и исправьте своё сообщение.
2. Я, видя, что количество строк большое, сразу предложил МАССИВЫ (вариант реализации предложил Sanja)  - Вы показываете макрос, работающий с ячейками листа.
3. Мой вариант без цикла.
 
 
 
#19
01.06.2017 11:53:45
Продолжу брюзжать:
Цитата
Cold_sauce написал:
любое значение при выполнение условия( 1,0 ; да,нет; true, false)
Вот это нормальная формулировка - перечень возможных значений.

А вот такая:
Цитата
Cold_sauce написал:
Результатом может быть все что угодно
ничего, кроме улыбки, вызвать не может.
 
 
 
#20
01.06.2017 11:57:29
Юрий М, ну если ничего кроме улыбки, то можно было и такие варианты ( :), :( ), по поводу кода в сообщение, к сожалению сей час поправить не получится ибо даювижок браузера телефона не позволяет этого сделать, дома буду поправлю.
 
 
 
#21
01.06.2017 12:00:40
Ну а как быть с предложенными вариантами макроса? Где ответ на мой вопрос в #14?
 
 
 
#22
01.06.2017 12:07:06
Юрий М, Дело в том, что я не знаю как именно применить .countif и сейчас пробую варианты которые вы предложили.
 
 
 
#23
01.06.2017 12:18:41
Sanja, проверил ваш вариант макроса, в итоге он выдаёт количество ячеек в массиве. А хотелосьбы увидеть рядом с каждым значением либо количество повторений в массиве, либо при условии > 70 любой из вариантов которые уже обсуждались выше
заранее огромное спасибо за помощь
 
 
 
#24
01.06.2017 12:26:46
Cold_sauce, давайте сделаем так: придёте домой - подготовьте файл-пример. 270 000 строк не нужно - достаточно и 30-50. Покажете исходные данные и желаемый результат. Всё в реальной структуре.
 
 
 
#25
01.06.2017 12:29:53
Юрий М, хорошо. Так и поступим.  
 
 
 
#26
01.06.2017 13:07:55
Исходя из Вашего стартового сообщения предположил, что исходные данные у Вас в столбце D. Начинаются со второй строки. Макрос выведет массив с нужной информацией в ячейку F2.
Код
Sub Macro1()
Dim LastRow As Long, i As Long, vValue, Arr(), Uniq As New Collection, k As Long
    LastRow = Cells(Rows.Count, 4).End(xlUp).Row
    Arr = Range(Cells(2, 4), Cells(LastRow, 4)).Value
    For i = 1 To UBound(Arr)
        On Error Resume Next
        Uniq.Add Arr(i, 1), CStr(Arr(i, 1))
    Next
    ReDim arr2(1 To Uniq.Count, 1 To 3)
    For Each vValue In Uniq
        k = k + 1
        arr2(k, 1) = vValue
        For i = 1 To UBound(Arr)
            If Arr(i, 1) = vValue Then
                arr2(k, 2) = arr2(k, 2) + 1
            End If
        Next
    Next
    For i = 1 To Uniq.Count
        If arr2(i, 2) > 70 Then
            arr2(i, 3) = True
        Else
            arr2(i, 3) = False
        End If
    Next
    Range("F2").Resize(k, 3).Value = arr2
End Sub
 
 
 
#27
01.06.2017 15:34:57
И мой вариант
Collection VS Dictionary  ;)
Код
Sub SumIfMacro()
Dim arrVal(), arrTemp(), arrKey, dicUnique As Object, dicVal As Object, I&, Key
With ActiveSheet
    lRow = .Cells(.Rows.Count, "D").End(xlUp).Row
    arrVal = .Range("D2:D" & lRow).Value  'диапазон от D2 до последней ячейки с данными в столбце D
    Set dicVal = CreateObject("Scripting.Dictionary")
    Set dicUnique = CreateObject("Scripting.Dictionary")
    ReDim arrTemp(1 To UBound(arrVal, 1), 1 To 2)
    On Error Resume Next
    For I = 1 To UBound(arrVal)
        b = IIf(arrVal(I, 1) > 70, "^Да", "^Нет")   'условие (>70)
        dicVal.Add CStr(arrVal(I, 1) & "^" & I & b), arrVal(I, 1)
        dicUnique.Add CStr(arrVal(I, 1)), 1
        If Err <> 0 Then
            dicUnique(CStr(arrVal(I, 1))) = dicUnique(CStr(arrVal(I, 1))) + 1
            Err.Clear
        End If
    Next
    For Each Key In dicVal.Keys
        arrKey = Split(Key, "^")
        If dicUnique.Exists(arrKey(0)) Then arrTemp(arrKey(1), 1) = dicUnique(arrKey(0))
        arrTemp(arrKey(1), 2) = arrKey(2)
    Next
    Application.ScreenUpdating = False
    With .Range("E2").Resize(UBound(arrTemp, 1), 2)
        .ClearContents
        .Value = arrTemp
    End With
End With
Application.ScreenUpdating = True
End Sub
Согласие есть продукт при полном непротивлении сторон
 
 
 
#28
01.06.2017 21:05:55
Sanja,Огромное спасибо, ваш вариант работает очень быстро 270к строк обрабатываются в течение 5 секунд! единственное что вы написали если значение ячейки > 70 тогда да, но по условию было другое, а именно если количество повторов >70

как и обещал выкладываю пример, естественно большинство данных удалил, но в конце оставил формулы для дальнейшего преобразования. в столбце CC находиться формула, для которой и нужен макрос, чтобы можно было в дальнейшем посчитать другие параметры зависящие от кол-ва повторений.
 
 
 
#29
01.06.2017 21:38:07
Код
Sub SumIfMacro()
Dim arrVal(), arrTemp(), arrKey, dicUnique As Object, dicVal As Object, i&, Key
With ActiveSheet
    lRow = .Cells(.Rows.Count, "D").End(xlUp).Row
    arrVal = .Range("D14:D" & lRow).Value  'диапазон от D14 до последней ячейки с данными в столбце D
    Set dicVal = CreateObject("Scripting.Dictionary")
    Set dicUnique = CreateObject("Scripting.Dictionary")
    ReDim arrTemp(1 To UBound(arrVal, 1), 1 To 2)
    On Error Resume Next
    For i = 1 To UBound(arrVal)
        dicVal.Add CStr(arrVal(i, 1) & "^" & i), arrVal(i, 1)
        dicUnique.Add CStr(arrVal(i, 1)), 1
        If Err <> 0 Then
            dicUnique(CStr(arrVal(i, 1))) = dicUnique(CStr(arrVal(i, 1))) + 1
            Err.Clear
        End If
    Next
    For Each Key In dicVal.Keys
        arrKey = Split(Key, "^")
        If dicUnique.Exists(arrKey(0)) Then arrTemp(arrKey(1), 1) = dicUnique(arrKey(0))
        arrTemp(arrKey(1), 2) = IIf(dicUnique(arrKey(0)) > 70, True, False)
    Next
    Application.ScreenUpdating = False
    .Range("E14").Resize(UBound(arrTemp, 1), 2) = arrTemp
End With
Application.ScreenUpdating = True
End Sub
Изменено: Sanja - 01.06.2017 21:38:40
Согласие есть продукт при полном непротивлении сторон
 
 
 
#30
01.06.2017 22:32:46
Цитата
Cold_sauce написал:
Sanja ,Огромное спасибо, ваш вариант работает очень быстро 270к
А мой вариант хоть проверили? )
 
 
 
Страницы: 1 2 След.
Читают тему
Наверх