Цикл занимает слишком много времени для выполнения кода

Question

В файле Excel у меня 600000 строк, и приведенный ниже код занимает слишком много времени для выполнения. Получается 150 строк за 1 минуту. Любое предложение по улучшению кода ниже?

For i = 2 To UBound(vArray, 1)
    With Worksheets(1).Range("C2:C" & Z)
        Set c = .Find(Sheet2.Cells(i, "A"), LookIn:=xlValues)
        If Not c Is Nothing Then
            firstaddress = c.Address
            Do
              If Sheet2.Cells(i, "A") = Sheet.Cells(c.Row, 3) Then
                 If UCase(Sheet1.Cells(c.Row, "D")) = "AVDELING" Then
                    Sheet2.Cells(i, 2) = Sheet1.Cells(c.Row, 5)
                 ElseIf UCase(Sheet1.Cells(c.Row, "D")) = "PROSJEKT" Then
                    Sheet2.Cells(i, 3) = Sheet1.Cells(c.Row, 5)
                 End If
             End If
                Set c = .FindNext(c)
                If firstaddress = c.Address Then
                    GoTo end_this
                End If
            Loop While Not c Is Nothing
        End If
    End With
end_this:
Next i

Answer 1

Попробуйте использовать массивы памяти вместо диапазонов Excel для поиска и сохранения результатов. Код ниже выполняется за несколько секунд.

Sub Test()
  Dim findWhat() As Variant
  Dim findIn() As Variant
  Dim rowNum As Long
  Dim findIndex As Long
  Dim results() As Variant

  findWhat = Array("A10", "B5", "C3")
  findIn = Range("A1:A640000").Value
  results = Range("B1:D640000").Value

  For findIndex = LBound(findWhat) To UBound(findWhat)
    For rowNum = LBound(findIn) To UBound(findIn)
      If findWhat(findIndex) = findIn(rowNum, 1) Then
        results(rowNum, 1) = "Found " & findIndex
      End If
    Next rowNum
  Next findIndex

  Range("B1:D640000").Value = results
End Sub