Поиск  Пользователи  Правила  Войти
Форумы "Планета Excel" » Вопросы по Microsoft Excel
Страницы: 1
RSS
Долгий поиск в коллекции, Макрос работает более 3 часов конца
 
#1
20.01.2017 16:43:14
Добрый день! Вчера поднимал вопрос по поиску в коллекции.
Спасибо большое форумчанам подсказали функцию.

Протестил на маленьком объеме все норм.

Но когда начинаю заполнять книгу в ней 3 тысячи строк и 75 столбцов, комбинацию по которым надо найти,
макрос уходить в оооооочень долго его считать

Вот код функции поиска в коллекции
Код
Function CollectionContains(myCol As Collection, checkVal As Variant) As Boolean
    On Error Resume Next
    CollectionContains = False
    Dim it As Variant
    For Each it In myCol
        If it = checkVal Then
            CollectionContains = True
            Exit Function
        End If
    Next
End Function
Вот код макроса который очень долго отрабатывает
Код
n = Sheet.Cells.SpecialCells(xlLastCell).Row              максимальное значение n 3000
        For y = 52 To 126
            For x = 5 To n
                If CollectionContains(coll_TS, Sheet.Cells(3, y) & Sheet.Cells(x, 7)) Then     'Проверка ключа в коллекции
                    Sheet.Cells(x, y) = "1"
                Else
                    Sheet.Cells(x, y) = ""
                End If
            Next
Возможно ли как-то оптимизировать код?  Конечно есть возможность запустить в ночь, но хочу развиваться в VBA и думаю есть у кого-то решение
 
 
 
#2
20.01.2017 16:44:16
Забыл дописать, коллекция кстати тоже не маленькая 600 000 строк
 
 
 
#3
20.01.2017 16:50:45
Уходите от перебора ячеек. Внесите данные в массив, перебирайте и сравнивайте элементы массива. Так-же результирующие значения вносите в массив, который уже потом выгружайте на лист
Примерно так
Код
n = Sheet.Cells.SpecialCells(xlLastCell).Row              'максимальное значение n 3000
Dim arrVal(5 To n, 52 To 126)
arrVal = Range(Cells(5, 52), Cells(n, 126)).Value
    For y = LBound(arrVal, 1) To UBound(arrVal, 1)
        For x = LBound(arrVal, 2) To UBound(arrVal, 2)
            If CollectionContains(coll_TS, arrVal(3, y) & arrVal(x, 7)) Then     'Проверка ключа в коллекции
                arrVal(x, y) = "1"
            Else
                arrVal(x, y) = ""
            End If
        Next
    Next
Изменено: Sanja - 20.01.2017 17:08:50
Согласие есть продукт при полном непротивлении сторон
 
 
 
#4
20.01.2017 17:09:31
Да и вообще здесь вместо коллекций словари напрашиваются...
Там есть метод Exists, который делает тоже самое, что в прошлой теме упоминали - аналог Contains. Т.е. проверяет наличие ключа в словаре.

Если почти ничего не менять, то если эту часть записать так:
Код
   Dim n As Long
    n = Sheet.Cells.SpecialCells(xlLastCell).Row
    ' сразу очищаем диапазон ячеек
    ' при этом используем Empty, а не строку нулевой длины
    ' так ячейки будут реально пустыми, а не видимость
    Sheet.Cells(5, 52).Resize(n - 5, 74).Value = Empty
    For y = 52 To 126
        For x = 5 To n
            If CollectionContains(coll_TS, Sheet.Cells(3, y) & Sheet.Cells(x, 7)) Then     'Проверка ключа в коллекции
                Sheet.Cells(x, y) = "1"
            'этот блок становится не нужен, т.к. очистили вначале
    '        Else
    '            Sheet.Cells(x, y) = ""
            End If
        Next
    Next
То уже будет чуть быстрее, т.к. очищаем сразу все участвующие в проверке ячейки, а заполняем их потом по мере необходимости. Раньше у Вас независимо ни от чего изменялось значение каждой ячейки.
Можно еще и массивы привлечь, но на большем кол-ве данных они могут выдать ошибку Out Of memory.
Еще чуть быстрее и без переполнения памяти должен работать такой вариант:
Код
   Dim n As Long, arrR, arrC
    n = Sheet.Cells.SpecialCells(xlLastCell).Row
    ' сразу очищаем диапазон ячеек
    ' при этом используем Empty, а не строку нулевой длины
    ' так ячейки будут реально пустыми, а не видимость
    Sheet.Cells(5, 52).Resize(n - 5, 74).Value = Empty
    'создаем массив для обращения к ячейкам строки
    arrC = Sheet.Cells(3, 1).Resize(, y).Value
    For y = 52 To 126
        'массив со значениями столбца 7
        arrR = Sheet.Cells(1, 7).Resize(n).Value
        For x = 5 To n
            If CollectionContains(coll_TS, arrC(1, y) & arrR(x, 1)) Then
                Sheet.Cells(x, y) = "1"
            'этот блок становится не нужен, т.к. очистили вначале
    '        Else
    '            Sheet.Cells(x, y) = ""
            End If
        Next
    Next
Изменено: The_Prist - 20.01.2017 17:13:46
Даже самый простой вопрос можно превратить в огромную проблему. Достаточно не уметь формулировать вопросы...
 
 
 
#5
20.01.2017 17:25:50
Вообще проверку наличия в коллекции можно делать добавляя элемент в коллекцию, так обычно и делают. И не придётся каждый раз перебирать 600 000 элементов.
А про словарь я тоже уже говорил в той теме  - но словарь только для Виндовс.
Вообще словарь+массив быстро решают большинство проблем :)
Изменено: Hugo - 20.01.2017 17:27:32
 
 
 
#6
20.01.2017 17:44:44
Цитата
Hugo написал:
добавляя элемент в коллекцию
я думал об этом, Игорь. Но тут есть одно но: если элемент добавится, ошибка не возникнет. А если это значение встречается в массиве не один раз? Ведь после первого добавления второй раз добавление вызовет ошибку и будет считаться как присутствующее в коллекции, а не должно по логике проверки.
Даже самый простой вопрос можно превратить в огромную проблему. Достаточно не уметь формулировать вопросы...
 
 
 
#7
20.01.2017 17:57:23
Если не добавилось - значит было.
А если добавилось - значит небыло, и может так и надо чтоб теперь было. А если ненадо - можно его из коллекции тут же изъять.
Вообще конечно нужен словарь - код будет простой и быстрый.
Изменено: Hugo - 20.01.2017 17:58:21
 
 
 
Страницы: 1
Читают тему
Наверх