Row processing taking too long

Question

I'm currently working on an excel that processes around 500 registers, from another worksheet. The function imports a file, and then creates categories, using an index and match function (will use also another two elements to split the categories, that I copy with the for). Later, another function will create individual groups on different pages.

The problem I'm facing is the amount of time it takes to process the data, which is around 5 seconds per row. Obviously, I'm doing something wrong here, even if it works. Any ideas on how to make it better or improve the code?

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

First thing you should do is [avoid using Select in Excel VBA](https://stackoverflow.com/questions/10714251/how-to-avoid-using-select-in-excel-vba). If your code works (no errors) and your question is only about performance you would better ask it at https://codereview.stackexchange.com/ — Pᴇʜ, Jul 14 '20 at 09:55

TerrifiedJelly · Accepted Answer · 2020-07-14T15:34:37.780

With this section, I've always found it faster to do destinationrange.value = sourcerange.value like this.

From this:

'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

to this:

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

Also, you could try turning calculations off until you need the sheet to recalculate using:

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

Finally, if you're putting in a formula in to the sheet as part of the VBA, you can do it like this:

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

Where LastRow has already been assigned using whichever method you prefer.

These changes should help reduce the processing time.

Row processing taking too long

1 Answers1