Обработка строки занимает слишком много времени

Question

Сейчас я работаю над Excel, который обрабатывает около 500 регистров из другого рабочего листа. Функция импортирует файл, а затем создает категории, используя функцию индекса и сопоставления (также будут использоваться еще два элемента для разделения категорий, которые я копирую с помощью for). Позже другая функция создаст отдельные группы на разных страницах.

Проблема, с которой я столкнулся, заключается в количестве времени, необходимом для обработки данных, которое составляет около 5 секунд на строку. Очевидно, я здесь что-то не так делаю, даже если работает. Есть идеи, как сделать его лучше или улучшить код?

Sub Import_data()

Dim FilePath As Variant, FileName As Variant, TempSheetName As String, k As Integer, n As Integer
Dim pctdone As Single

Application.ScreenUpdating = False
Application.DisplayAlerts = False

TempSheetName = "REGISTER"
   
'Check that workbook is reset

For Each sheet In Worksheets
    If TempSheetName = UCase(sheet.Name) Then
      
    MsgBox "Reset before importing"
    Exit Sub
    End If
Next sheet

'File opening

FilePath = Application.GetOpenFilename(FileFilter:="Excel Files (*.XLSX), *.XLSX", Title:="Select File To Be Opened")
If FilePath = False Then Exit Sub

FileName = Mid$(FilePath, InStrRev(FilePath, "\") + 1, Len(FilePath))

ControlFile = ActiveWorkbook.Name
Workbooks.Open FileName:=FilePath
Sheets("REGISTER").Copy After:=Workbooks(ControlFile).Sheets("LOT")
Windows(FileName).Activate
ActiveWorkbook.Close SaveChanges:=False
Windows(ControlFile).Activate

'Progress Bar display
ufProgress.LabelProgress.Width = 0
ufProgress.Show

'Progress Bar text
With ufProgress
        .LabelCaption.Caption = "Processing Data" & lastrow
End With
DoEvents

'Main lot creation

Sheets("LOT").Select
    Range("A9").Select
    ActiveCell.Formula2R1C1 = _
        "=UNIQUE(FILTER(REGISTER!R7C3:R65536C3,REGISTER!R7C3:R65536C3<>""""))"

'Progress Bar text
With ufProgress
        .LabelCaption.Caption = "Removing formulas"
End With
DoEvents


'Formulas to values
Sheets("REGISTER").Select
Columns("B:B").Select
Application.CutCopyMode = False
Selection.Copy
Selection.PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks _
        :=False, Transpose:=False

Columns("V:V").Select
Application.CutCopyMode = False
Selection.Copy
Selection.PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks _
        :=False, Transpose:=False

Columns("Y:Y").Select
Application.CutCopyMode = False
Selection.Copy
Selection.PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks _
        :=False, Transpose:=False

'Lot assignement

n = 6 + Application.WorksheetFunction.Max(Sheets("REGISTER").Range("B7:B15000"))

For k = 7 To n

pctdone = k / n
    With ufProgress
        .LabelCaption.Caption = "Processing Row " & k & " of " & n
        .LabelProgress.Width = pctdone * (.FrameProgress.Width)
    End With
    DoEvents

If Sheets("REGISTER").Range("B" & k).Value > 0 Then

Sheets("REGISTER").Range("AA" & k).Value = WorksheetFunction.IfError(WorksheetFunction.Index(Sheets("LOT").Range("C9:C35"), WorksheetFunction.Match(Sheets("REGISTER").Range("C" & k).Value, Sheets("LOT").Range("A9:A35"), 0)), "")
Sheets("REGISTER").Range("AB" & k).Value = Sheets("REGISTER").Range("H" & k).Value
Sheets("REGISTER").Range("AC" & k).Value = Sheets("REGISTER").Range("V" & k).Value

If i = n Then Unload ufProgress

End If
Next k


Sheets("CONTROL").Activate

Application.ScreenUpdating = True
Application.DisplayAlerts = True
End Sub

Answer 1

В этом разделе я всегда считал, что быстрее делать destinationrange.value = sourcerange.value вот так.

Отсюда:

'Formulas to values
Sheets("REGISTER").Select
Columns("B:B").Select
Application.CutCopyMode = False
Selection.Copy
Selection.PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks _
        :=False, Transpose:=False

до этого:

sheets("REGISTER").Range("B:B").value = sheets("REGISTER").Range("B:B").value

Кроме того, вы можете попробовать отключить вычисления до тех пор, пока вам не понадобится лист для пересчета, используя:

Application.Calculation = xlAutomatic
[bit where you need it to calculate]
Calculate
Application.Calculation = xlCalculateManual

Наконец, если вы вводите формулу на лист как часть VBA, вы можете сделать это следующим образом:

LastRow = 100
sheets("Sheet").range("A1").value = "=SUM(A:A)"
sheets("Sheet")range("A1").AutoFill Destination:=Range("A1:A" & LastRow) 

Где LastRow уже был назначен с использованием того метода, который вы предпочитаете.

Эти изменения должны помочь сократить время обработки.