How to optimize code in VBA?

Question

Macros

Good day, toasters. There is an Excel document containing 180K lines. It needs to be processed as follows, we select the street, house number, building , look in the table for objects at this address, these objects analyze the columns containing the year of construction (some may not have it , the year is in 2 columns, we analyze and that and that ) and the material of the walls of the object, then we find the most common year (the material of the walls) and put down this parameter for all other objects. The below code works but Excel freezes and dies. How to optimize this script? Give advice.

the code

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

Answer 1

1st
You can revive Excel (that is, save it from freezing) by adding the "DoEvents" command before each "next ..." statement. But I want to warn you that this will increase the total execution time of the entire code, i.e. this command causes Excel to stop your code and process the user or system actions that have accumulated so far.
Example

...
    DoEvents
next x
...

You need to get rid of frequent access to the cells. This is done by copying the entire data dump in one go.

вместо
    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 )

Next in the code are constant calls to cells inside nested loops
In general, you need to analyze the algorithm and remove all cyclic calls to cells. Replace them with calls to arrays that will be pre-populated by copying dumps (as shown above).
Further (possibly?!, if the algorithm allows) to reduce the number of cycles by sorting the source data and binary search in arrays.
For reference: Binary search finds data in about 7-8 array accesses, while simple enumeration (which is organized by you) makes 180k accesses in the worst case.
There is room for optimization here.
And make a backup before editing.