Как оптимизировать код в VBA?

Question

[Александр Шилов]

Доброго времени суток, тостеры. Есть документ Excel, содержащий 180К строк. Его нужно обработать следующим образом, мы отбираем улицу, номер дома, корпус, ищем в таблице объекты по этому адресу, у этих объектов анализирует столбцы, содержащие год постройки (у некоторых его может не быть, год находится в 2-х столбцах, анализируем и тот и тот) и материал стен объекта, далее находим наиболее часто встречающийся год (материал стен) и у всех остальных объектов проставляем данный параметр. Нижепредставленный код работает, но Excel зависает и умирает. Как оптимизировать данный скрипт? Подскажите советом.

код

Sub searchAddress()
    Dim rows, i, max, index As Long
    Dim address, addressArr As String
    
    rows = Cells(1, 1).End(xlDown).Row
    'MsgBox (rows)
    
    Dim arrStreet(), arrHouse(), arrCampus(), yearArr(), wArr(), cwArr() As String
    Dim cYearArr() As Integer
    Dim countY, countW As Integer
    
    ReDim arrStreet(rows - 1)
    ReDim arrHouse(rows - 1)
    ReDim arrCampus(rows - 1)
    
    
    For i = 1 To rows
        arrStreet(i - 1) = Cells(i, 71)
        arrHouse(i - 1) = Cells(i, 15)
        arrCampus(i - 1) = Cells(i, 34)
    Next i
    For strows = 1 To rows
        countY = 0
        countW = 0
        ReDim yearArr(countY)
        ReDim cYearArr(countY)
        ReDim wArr(countW)
        ReDim cwArr(countW)
        address = arrStreet(strows) & arrHouse(strows) & arrCampus(strows)
        For i = strows To rows - 1
            addressArr = arrStreet(i) & arrHouse(i) & arrCampus(i)
            If address = addressArr Then
                If Cells(i + 1, 5) <> "" Then
                    countY = countY + 1
                    ReDim Preserve yearArr(countY)
                    ReDim Preserve cYearArr(countY)
                    cYearArr(countY) = Int(0)
                    yearArr(countY) = Cells(i + 1, 5)
                    For x = 0 To countY
                        If yearArr(countY) = yearArr(x) Then
                            cYearArr(countY) = cYearArr(countY) + 1
                        End If
                    Next x
                ElseIf Cells(i + 1, 6) <> "" Then
                    countY = countY + 1
                    ReDim Preserve yearArr(countY)
                    ReDim Preserve cYearArr(countY)
                    cYearArr(countY) = 0
                    yearArr(countY) = Cells(i + 1, 6)
                    For x = 0 To countY
                        If yearArr(countY) = yearArr(x) Then
                            cYearArr(countY) = cYearArr(countY) + 1
                        End If
                    Next x
                End If
                If Cells(i + 1, 36) <> "" Then
                    countW = countW + 1
                    ReDim Preserve wArr(countW)
                    ReDim Preserve cwArr(countW)
                    cwArr(countW) = 0
                    wArr(countW) = Cells(i + 1, 36)
                    For x = 0 To countW
                        If wArr(countW) = wArr(x) Then
                            cwArr(countW) = cwArr(countW) + 1
                        End If
                    Next x
                End If
                Cells(i + 1, 90) = 1
            End If
        Next i
        
        max = 0
        index = 0
        For y = 0 To countY
            If max < cYearArr(y) Then
                max = cYearArr(y)
                index = y
            End If
        Next y
        
        For x = 2 To rows
            If Cells(x, 90) = 1 Then
                Cells(x, 91) = yearArr(index)
                Cells(x, 90) = 2
            End If
        Next x
        
        max = 0
        index = 0
        For y = 0 To countW
            If max < cwArr(y) Then
                max = cwArr(y)
                index = y
            End If
        Next y
        
        For x = 2 To rows
            If Cells(x, 90) = 2 Then
                Cells(x, 92) = wArr(index)
                Cells(x, 90) = 3
            End If
        Next x
    Next strows
End Sub

Comments

[idShura]

Не думали о переносе данных в базу данных?

[Александр Шилов]

idShura, думали, но не я решаю :-(

Answer 1

[Пычев Анатолий]

1-е
Оживить Excel (т.е. избавить его от зависания) Вы можете путем добавления перед каждой инструкцией "next ..." команды "DoEvents". Но хочу предупредить, что это увеличит общее время выполнения всего кода, т.е. эта команда заставляет Excel останавливать Ваш код и обрабатывать действия пользователя или системные, которые к этому моменту накопились.
Пример

...
    DoEvents
next x
...

2-е
Вам надо избавиться от частого обращения к ячейкам. Это делается путем копирования всего дампа данных за один раз.

вместо
    For i = 1 To rows
        arrStreet(i - 1) = Cells(i, 71)
        arrHouse(i - 1) = Cells(i, 15)
        arrCampus(i - 1) = Cells(i, 34)
    Next i

Используем
        'таким образом мы убираем цикл длиной в 180к *3 обращений к листу
        ' если протестировать затраты времени только на этом участке, экономия будет колоссальная
        arrStreet = range(Cells(1, 71), Cells(rows, 71))
        arrHouse = range(Cells(1, 15), Cells(rows, 15))
        arrCampus = range(Cells(1, 34), Cells(rows, 34))
        
       ' Но т.к. теперь мы имеем 2х мерные массивы, их надо обратить в одномерные, т.к. последующий код использует одномерные.
       arrStreet = WorksheetFunction.Transpose(arrStreet)
       arrHouse = WorksheetFunction.Transpose(arrHouse )
       arrCampus = WorksheetFunction.Transpose(arrCampus )

3-е
Далее по коду идут постоянные обращения к ячейкам внутри вложенных циклов


В общем надо проанализировать алгоритм и убрать все циклические обращения к ячейкам. Заменить их обращениями к массивам, которые предварительно будут заполнены копированием дампов (как показано выше).
Далее (возможно?!, если позволит алгоритм) уменьшить количество циклов за счет сортировки исходных данных и бинарного поиска по массивам.
Для справки: Бинарный поиск находит данные примерно за 7-8 обращений к массиву, тогда как простой перебор (который организован у Вас) делает в худшем случае 180к обращений.

Здесь есть простор для оптимизации.
И сделайте бэкап перед редактированием.

Comments

[h8nor]

1. Алгоритм бинаркого поиска (массив должен быть отсортирован по возрастанию).
   Нужно только исправить BinSearch = -1 на BinSearch = IIf(A(b%, 1) = v, b%, -1)
   
2. Двоичный поиск с сортировкой
   

О сортировке: Что быстрее, простой поиск или сортировка + поиск?

[Александр Шилов]

Дѣаволъ, а если массив состоит из строк, как он будет сортироваться по возрастанию?

[h8nor]

Александр Шилов, зависит от того, как написана функция сравнения (в целом буквы переводятся в коды символов и сравниваются/сортируются).