Small datasheet code running super slow on Excel VBA

Question

The code has been super useful with my work datasheets. They all have this pattern and the VBA code makes sure it all has the right format.

Why is it so slow?

Sometimes it takes 2~3 minutes to run a few lines of data.

Sub a_organizar_protocolo()
 On Error Resume Next
 Application.DisplayFormulaBar = False
 Application.ScreenUpdating = False
 Application.Calculation = xlCalculationManual
 Application.EnableEvents = False
 Application.InterActive = False
 ActiveWorkbook.Save
 ActiveSheet.AutoFilterMode = False
 ActiveWindow.Zoom = 90
 Columns("O:P").ClearContents
 Columns("R:R").ClearContents
 With Cells
 .VerticalAlignment = xlCenter
 .HorizontalAlignment = xlCenter
 .Borders(xlDiagonalDown).LineStyle = xlNone
 .Borders(xlDiagonalUp).LineStyle = xlNone
 .WrapText = False
 .Orientation = 0
 .AddIndent = False
 .IndentLevel = 0
 .ShrinkToFit = False
 .ReadingOrder = xlContext
 .MergeCells = False
 With .Borders
 .LineStyle = xlContinuous
 .ColorIndex = 0
 .Weight = xlThin
 End With
 With .Font
 .Name = "Calibri"
 .Size = 11
 .ColorIndex = xlAutomatic
 .Bold = False
 .Italic = False
 End With
 End With
 With Rows("1:1")
 .RowHeight = 32
 .Interior.ColorIndex = 49
 .WrapText = True
 With .Font
 .Size = 12
 .Bold = True
 .ColorIndex = 44
 End With
 End With
 With ActiveWindow
 .FreezePanes = False
 .SplitColumn = 0
 .SplitRow = 1
 .FreezePanes = True
 End With
 With Rows("2:" & Rows.Count)
 .RowHeight = 15
 .Interior.Color = xlNone
 End With
 Columns("A:A").ColumnWidth = 15
 Columns("B:B").ColumnWidth = 14
 Columns("C:C").ColumnWidth = 20
 Columns("D:D").ColumnWidth = 30
 Columns("E:E").ColumnWidth = 14
 Columns("F:F").ColumnWidth = 11
 Columns("G:G").ColumnWidth = 40
 Columns("H:H").ColumnWidth = 14
 Columns("I:I").ColumnWidth = 14
 Columns("J:J").ColumnWidth = 16
 Columns("K:K").ColumnWidth = 20
 Columns("L:L").ColumnWidth = 10
 Columns("M:M").ColumnWidth = 8
 Columns("N:N").ColumnWidth = 12
 Columns("O:O").ColumnWidth = 5
 Columns("P:P").ColumnWidth = 14
 Columns("Q:R").ColumnWidth = 25
 Range("A1").Value = "Lançamento"
 Range("B1").Value = "Data de Recebimento"
 Range("C1").Value = "Solicitante"
 Range("D1").Value = "Espécie do Documento"
 Range("E1").Value = "Número da Nota Fiscal"
 Range("F1").Value = "Código do Fornecedor"
 Range("G1").Value = "Fornecedor"
 Range("H1").Value = "Centro de Custo"
 Range("I1").Value = "Vencimento"
 Range("J1").Value = "Valor"
 Range("K1").Value = "Descrição"
 Range("L1").Value = "Pedido"
 Range("M1").Value = "Item do Pedido"
 Range("N1").Value = "Pagamento"
 Range("O1").Value = "Validação"
 Range("P1").Value = "Prioridade"
 Range("Q1").Value = "Observação"
 Range("R1").Value = "Concatenar"
 Dim qa, q1, q2, q3 As Range
 Set q1 = Range(Range("G2"), Range("G" & Rows.Count))
 Set q2 = Range(Range("J2"), Range("K" & Rows.Count))
 Set q3 = Range(Range("Q2"), Range("R" & Rows.Count))
 Set qa = Union(q1, q2, q3)
 qa.HorizontalAlignment = xlLeft
 Dim ea, e1, e2 As Range
 Set e1 = Range(Range("G2"), Range("G2").End(xlDown))
 Set e2 = Range(Range("K2"), Range("K2").End(xlDown))
 Set ea = Union(e1, e2)
 With ea
 .Replace What:=".", Replacement:=""
 .Replace What:="/", Replacement:=""
 .Replace What:=":", Replacement:=""
 .Replace What:="–", Replacement:="-"
 End With
 Dim r0, ra As Range
 Set r0 = Range(Range("E2"), Range("E2").End(xlDown))
 For Each ra In r0
 If Len(ra.Value) > 9 Then ra.Value = Right(ra.Value, 9)
 Next
 r0.Replace What:="x", Replacement:="0"
 Dim ta, tb As Range
 Dim t1, t2, t3, t4 As Range
 t0 = Range("E:E").SpecialCells(xlCellTypeLastCell).Row
 Set t1 = Range("E2:E" & t0)
 Set t2 = Range("F2:F" & t0)
 Set t3 = Range("H2:H" & t0)
 Set t4 = Range("L2:M" & t0)
 Set tb = Union(t1, t2, t3, t4)
 For Each ta In tb
 tc = ""
 For t = 1 To Len(ta.Value)
 td = Mid(ta.Value, t, 1)
 If td Like "[0-9]" Then
 te = td
 Else
 te = ""
 End If
 tc = tc & te
 Next t
 ta.Value = tc
 Next
 Dim ya, yb As Range
 Set yb = Range(Range("J2"), Range("J2").End(xlDown))
 For Each ya In yb
 yc = ""
 For y = 1 To Len(ya.Value)
 yd = Mid(ya.Value, y, 1)
 If yd Like "[0-9],-" Then
 ye = yd
 Else
 ye = ""
 End If
 yc = yc & ye
 Next y
 ya.Value = yc * 1
 Next
 Dim ia, ib As Range
 Set ib = Range(Range("J2"), Range("J2").End(xlDown))
 For Each ia In ib
 If ia.Value < 0 Then
 With ia
 .Offset(0, -1).Value = "31/12/" & (Year(Date) + 1)
 .Offset(0, -2).Value = "NA"
 .Offset(0, 2).Value = "NA"
 .Offset(0, 3).Value = "NA"
 End With
 End If
 Next
 Dim oa, ob As Range
 Set ob = Range(Range("D2"), Range("D2").End(xlDown))
 For Each oa In ob
 If oa.Value = "Ouvidoria" Then
 With oa
 .Offset(0, -1).Value = oa.Value
 .Offset(0, 8).Value = "NA"
 .Offset(0, 9).Value = "NA"
 .Offset(0, 10).Value = "DEPÓSITO"
 End With
 End If
 Next
 Dim pa, pb, p1, p2 As Range
 Set p1 = Columns("H:H").SpecialCells(xlCellTypeBlanks)
 For Each pa In p1
 pa.Value = "Estoque"
 Next
 Set p2 = Range(Range("H2"), Range("H2").End(xlDown))
 For Each pb In p2
 If pb.Value = "Estoque" Then pb.Offset(0, -7).Value = pb.Value
 Next
 Dim k1, k2, k3, k4, k5, ka, kb, kaa, kbb As Range
 Set k1 = Range(Range("A2"), Range("A2").End(xlDown))
 Set k2 = Range(Range("C2"), Range("C2").End(xlDown))
 Set k3 = Range(Range("G2"), Range("G2").End(xlDown))
 Set k4 = Range(Range("K2"), Range("K2").End(xlDown))
 Set k5 = Range(Range("N2"), Range("N2").End(xlDown))
 Set ka = Union(k1, k2)
 Set kb = Union(k3, k4, k5)
 For Each kaa In ka
 kaa.Value = StrConv(kaa.Value, vbProperCase)
 Next kaa
 For Each kbb In kb
 kbb.Value = UCase(kbb.Value)
 Next kbb
 Cells.Validation.Delete
 Cells.FormatConditions.Delete
 Range("E2").End(xlDown).Select
 Application.ScreenUpdating = True
 Application.Calculation = xlCalculationAutomatic
 Application.EnableEvents = True
 Application.InterActive = True
End Sub

---

_{People from Stack Overflow redirected me here.}

• BigBen: For Each ta In tb, For Each ya In yb, For Each ia In ib, For Each oa In ob, For Each pa In p1, For Each kaa In ka, For Each kbb In kb - all of these cell-by-cell read/write are slow.
• Mathieu Guindon: Won't help with performance, but there are a number of "low-hanging fruits" in here, including variable types not declared and implicit ActiveSheet references (these are a very common cause of bugs), that Rubberduck can quickly find and fix for you in this code. Also note that Range(Range("E2"), Range("E2")) is exactly equivalent to Range("E2"); worksheet reads/writes need to be limited to achieve better performance.
• Mathieu Guindon: Rubberduck inspections would also flag many of these variables for not using a meaningful identifier name, and the ta loop is iterating every single row across 4 columns, one by one: I suspect that's where more of the time is being spent.
• Peter - Reinstate Monica: I thought you said "small"?

Answer 1

You do not have look at more than about 2 Code Review answers to find posts that advocate two very important principles when writing code (in VBA or any other language). The "Do not repeat yourself" principle (DRY) and the "Single Responsibility Principle" (SRP). These two principles are important for writing efficient, readable, and correct code. So, getting to faster execution is easier if your code is implemented using the DRY and SRP principles.

Regarding execution speed, Union can be a slow operation. So, the suggestions below include refactoring the code in order to remove the use of Union by applying DRY and SRP.

SRP:

SRP advocates that each procedure fulfills a single responsibility for the program. When SRP is applied, long procedures naturally are broken down into smaller procedures. The result is code that is generally more reliable, readable, and efficient.

The posted Subroutine a_organizar_protocolo is composed of 249 lines. This is too many lines for most procedures (especially if they are fulfilling a single responsibility). Subroutine a_organizar_protocolo has the following responsibilities:

• Handle toggling Application flags
• Formats Cells
• Updates Content

The entry point procedure can fulfill the Application flag handling responsibility:

Sub a_organizar_protocolo()
 Application.DisplayFormulaBar = False
 Application.ScreenUpdating = False
 Application.Calculation = xlCalculationManual
 Application.EnableEvents = False
 Application.Interactive = False
 
On Error GoTo ErrorExit
 ActiveWorkbook.Save
 ActiveSheet.AutoFilterMode = False
 ActiveWindow.Zoom = 90
 
 FormatContent
 
 UpdateValues
 Cells.Validation.Delete
 Cells.FormatConditions.Delete
 Range("E2").End(xlDown).Select
ResetFlags: 
 Application.ScreenUpdating = True
 Application.Calculation = xlCalculationAutomatic
 Application.EnableEvents = True
 Application.Interactive = True
 Exit Sub
ErrorExit:
 Debug.Print "Error: " & Err.Description
 Goto ResetFlags
End Sub

ErrorHandling:

In the posted code, using On Error Resume Next at the top of the subroutine ignores every error that occurs during execution. There are times when ignoring all errors is appropriate...this is probably not one of them. It's possible that many errors are occurring within this subroutine - I cannot say for sure. More importantly, neither can you.

My suspicion is that `On Error Resume Next' was added to guarantee that the Application flags reset lines are executed. In the example above, it is now clear that the response to an error is to print an error message to the Immediate Window and reset the Application flags. And, a single error cancels the operation.

DRY: Code expressions that are repeated but with different constant strings/numbers result in code that is:

• More difficult to read
• Prone to typos
• More difficult to maintain

Where possible use code to reduce how much content is required to accomplish and update the necessary tasks. In the posted code, the same 'type' of operations are performed on columns "A" through "R". Using arrays and the Split function, these can be refactored to reduce repeated expressions.

The code:

 Columns("A:A").ColumnWidth = 15
 Columns("B:B").ColumnWidth = 14
 Columns("C:C").ColumnWidth = 20
 Columns("D:D").ColumnWidth = 30
 Columns("E:E").ColumnWidth = 14
 Columns("F:F").ColumnWidth = 11
 Columns("G:G").ColumnWidth = 40
 Columns("H:H").ColumnWidth = 14
 Columns("I:I").ColumnWidth = 14
 Columns("J:J").ColumnWidth = 16
 Columns("K:K").ColumnWidth = 20
 Columns("L:L").ColumnWidth = 10
 Columns("M:M").ColumnWidth = 8
 Columns("N:N").ColumnWidth = 12
 Columns("O:O").ColumnWidth = 5
 Columns("P:P").ColumnWidth = 14
 Columns("Q:R").ColumnWidth = 25 'Columns("Q:R") could be a typo error(?)
 Range("A1").Value = "Lançamento"
 Range("B1").Value = "Data de Recebimento"
 Range("C1").Value = "Solicitante"
 Range("D1").Value = "Espécie do Documento"
 Range("E1").Value = "Número da Nota Fiscal"
 Range("F1").Value = "Código do Fornecedor"
 Range("G1").Value = "Fornecedor"
 Range("H1").Value = "Centro de Custo"
 Range("I1").Value = "Vencimento"
 Range("J1").Value = "Valor"
 Range("K1").Value = "Descrição"
 Range("L1").Value = "Pedido"
 Range("M1").Value = "Item do Pedido"
 Range("N1").Value = "Pagamento"
 Range("O1").Value = "Validação"
 Range("P1").Value = "Prioridade"
 Range("Q1").Value = "Observação"
 Range("R1").Value = "Concatenar"

Can be refactored to:

 Dim columnFormatDefinitions As String
 columnFormatDefinitions = _
 "A:Lançamento:15," & _
 "B:Data de Recebimento:14," & _
 "C:Solicitante:20," & _
 "D:Espécie do Documento:30," & _
 "E:Número da Nota Fiscal:14," & _
 "F:Código do Fornecedor:11," & _
 "G:Fornecedor:40," & _
 "H:Centro de Custo:14," & _
 "I:Vencimento:14," & _
 "J:Valor:16," & _
 "K:Descrição:20," & _
 "L:Pedido:10," & _
 "M:Item do Pedido:8," & _
 "N:Pagamento:12," & _
 "O:Validação:5," & _
 "P:Prioridade:14," & _
 "Q:Observação:25," & _
 "R:Concatenar:25"
 
 Dim colLetter As String
 Dim colWidth As Long
 Dim colHeader As String
 Dim formatDefinition As Variant
 
 Dim formatElements As Variant
 For Each formatDefinition In Split(columnFormatDefinitions, ",")
 
 formatElements = Split(formatDefinition, ":")
 colLetter = formatElements(0)
 colHeader = formatElements(1)
 colWidth = CLng(formatElements(2))
 
 Columns(colLetter & ":" & colLetter).ColumnWidth = colWidth
 Range(colLetter & "1").Value = colHeader
 Next

Usually refactoring using the DRY priniciple results in fewer lines of code. That is not really the case here. What the refactored code does accomplish is the removal of all the repeated lines containing the expression Columns("X:X").ColumnWidth = ##. And, in the future, when column "S" is added, only "S:XXXX:##" needs to be added to the columnFormatDefinitions string. Also, if Columns("Q:R") is a typo, this kind of error is more easily found.

Union:

The code:

 Dim qa, q1, q2, q3 As Range
 Set q1 = Range(Range("G2"), Range("G" & Rows.Count))
 Set q2 = Range(Range("J2"), Range("K" & Rows.Count))
 Set q3 = Range(Range("Q2"), Range("R" & Rows.Count))
 Set qa = Union(q1, q2, q3)
 qa.HorizontalAlignment = xlLeft

relies on creating a Union of Ranges in order to apply horizontal alignment. However by using a helper subroutine the use of a Union can be avoided.

Using SRP and DRY, refactor this code into a helper subroutine:

Replace the code block above with:

ApplyHorizontalAlignment "G", "J", "Q" 

Where ApplyHorizontalAlignment is:

Private Sub ApplyHorizontalAlignment(ParamArray colLtrs() As Variant)
 
 Dim rangeOfInterest As Range
 Dim cLtr As Variant
 For Each cLtr In colLtrs
 Set rangeOfInterest = Range(Range(cLtr & "2"), Range(cLtr & Rows.Count))
 rangeOfInterest.HorizontalAlignment = xlLeft
 Next
End Sub

This same approach can be used to eliminate all uses of Union which may result is some efficiency improvements.

Putting it all together (with a couple more examples of removing the use of Union):

'Best Practice: Always declare Option Explicit at the top of your modules.
'Doing so requires all variable/fields to be declared before they are used
'or the code does not compile
Option Explicit
Sub a_organizar_protocolo()
 Application.DisplayFormulaBar = False
 Application.ScreenUpdating = False
 Application.Calculation = xlCalculationManual
 Application.EnableEvents = False
 Application.Interactive = False
 
On Error GoTo ErrorExit
 ActiveWorkbook.Save
 ActiveSheet.AutoFilterMode = False
 ActiveWindow.Zoom = 90
 Columns("O:P").ClearContents
 Columns("R:R").ClearContents
 FormatContent
 
 UpdateValues
 
 Cells.Validation.Delete
 Cells.FormatConditions.Delete
 Range("E2").End(xlDown).Select
ResetFlags: 
 Application.ScreenUpdating = True
 Application.Calculation = xlCalculationAutomatic
 Application.EnableEvents = True
 Application.Interactive = True
 Exit Sub
ErrorExit:
 Debug.Print "Error: " & Err.Description
 Goto ResetFlags
End Sub
Private Sub FormatContent()
 With Cells
 .VerticalAlignment = xlCenter
 .HorizontalAlignment = xlCenter
 .Borders(xlDiagonalDown).LineStyle = xlNone
 .Borders(xlDiagonalUp).LineStyle = xlNone
 .WrapText = False
 .Orientation = 0
 .AddIndent = False
 .IndentLevel = 0
 .ShrinkToFit = False
 .ReadingOrder = xlContext
 .MergeCells = False
 With .Borders
 .LineStyle = xlContinuous
 .ColorIndex = 0
 .Weight = xlThin
 End With
 With .Font
 .Name = "Calibri"
 .Size = 11
 .ColorIndex = xlAutomatic
 .Bold = False
 .Italic = False
 End With
 End With
 With Rows("1:1")
 .RowHeight = 32
 .Interior.ColorIndex = 49
 .WrapText = True
 With .Font
 .Size = 12
 .Bold = True
 .ColorIndex = 44
 End With
 End With
 With ActiveWindow
 .FreezePanes = False
 .SplitColumn = 0
 .SplitRow = 1
 .FreezePanes = True
 End With
 With Rows("2:" & Rows.Count)
 .RowHeight = 15
 .Interior.Color = xlNone
 End With
 
 FormatHeaders
 
 ApplyHorizontalAlignment "G", "J", "Q"
End Sub
Private Sub FormatHeaders()
 'Create a set of delimited format strings of the form <columnLetter:columnName:columnWidth>
 Dim columnFormatDefinitions As String
 columnFormatDefinitions = _
 "A:Lançamento:15," & _
 "B:Data de Recebimento:14," & _
 "C:Solicitante:20," & _
 "D:Espécie do Documento:30," & _
 "E:Número da Nota Fiscal:14," & _
 "F:Código do Fornecedor:11," & _
 "G:Fornecedor:40," & _
 "H:Centro de Custo:14," & _
 "I:Vencimento:14," & _
 "J:Valor:16," & _
 "K:Descrição:20," & _
 "L:Pedido:10," & _
 "M:Item do Pedido:8," & _
 "N:Pagamento:12," & _
 "O:Validação:5," & _
 "P:Prioridade:14," & _
 "Q:Observação:25," & _
 "R:Concatenar:25"
 
 Dim colLetter As String
 Dim colWidth As Long
 Dim colHeader As String
 Dim formatDefinition As Variant
 
 Dim formatElements As Variant
 For Each formatDefinition In Split(columnFormatDefinitions, ",")
 
 formatElements = Split(formatDefinition, ":")
 colLetter = formatElements(0)
 colHeader = formatElements(1)
 colWidth = CLng(formatElements(2))
 
 Columns(colLetter & ":" & colLetter).ColumnWidth = colWidth
 Range(colLetter & "1").Value = colHeader
 Next
End Sub
Private Sub ApplyHorizontalAlignment(ParamArray colLtrs() As Variant)
 
 Dim rangeOfInterest As Range
 Dim cLtr As Variant
 For Each cLtr In colLtrs
 Set rangeOfInterest = Range(Range(cLtr & "2"), Range(cLtr & Rows.Count))
 rangeOfInterest.HorizontalAlignment = xlLeft
 Next
End Sub
Private Sub UpdateValues()
 ReplaceSomeCharacters "G", "K"
 'ReplaceSomeCharacters replaces the code below
' Dim ea, e1, e2 As Range
' Set e1 = Range(Range("G2"), Range("G2").End(xlDown))
' Set e2 = Range(Range("K2"), Range("K2").End(xlDown))
' Set ea = Union(e1, e2)
' With ea
' .Replace What:=".", Replacement:=""
' .Replace What:="/", Replacement:=""
' .Replace What:=":", Replacement:=""
' .Replace What:="–", Replacement:="-"
' End With
 
 Dim r0, ra As Range
 Set r0 = Range(Range("E2"), Range("E2").End(xlDown))
 For Each ra In r0
 If Len(ra.Value) > 9 Then ra.Value = Right(ra.Value, 9)
 Next
 r0.Replace What:="x", Replacement:="0"
 Dim ta, tb As Range
 Dim t1, t2, t3, t4 As Range
 
 Dim t0 As Long
 
 t0 = Range("E:E").SpecialCells(xlCellTypeLastCell).Row
 
 ClearNonNumerics t0, "E2:E", "F2:F", "H2:H", "L2:M"
 'ClearNonNumerics replaces the code below
' Set t1 = Range("E2:E" & t0)
' Set t2 = Range("F2:F" & t0)
' Set t3 = Range("H2:H" & t0)
' Set t4 = Range("L2:M" & t0)
' Set tb = Union(t1, t2, t3, t4)
'
' Dim tc As String
' Dim td As String
' Dim te As String
' Dim t As Long
'
' For Each ta In tb
' tc = ""
' For t = 1 To Len(ta.Value)
' td = Mid(ta.Value, t, 1)
' If td Like "[0-9]" Then
' te = td
' Else
' te = ""
' End If
' tc = tc & te
' Next t
' ta.Value = tc
' Next
 Dim ya, yb As Range
 Set yb = Range(Range("J2"), Range("J2").End(xlDown))
 
 Dim yc As String
 Dim yd As String
 Dim ye As String
 Dim y As Long
 
 For Each ya In yb
 yc = ""
 For y = 1 To Len(ya.Value)
 yd = Mid(ya.Value, y, 1)
 If yd Like "[0-9],-" Then
 ye = yd
 Else
 ye = ""
 End If
 yc = yc & ye
 Next y
 ya.Value = yc * 1
 Next
 Dim ia, ib As Range
 Set ib = Range(Range("J2"), Range("J2").End(xlDown))
 For Each ia In ib
 If ia.Value < 0 Then
 With ia
 .Offset(0, -1).Value = "31/12/" & (Year(Date) + 1)
 .Offset(0, -2).Value = "NA"
 .Offset(0, 2).Value = "NA"
 .Offset(0, 3).Value = "NA"
 End With
 End If
 Next
 Dim oa, ob As Range
 Set ob = Range(Range("D2"), Range("D2").End(xlDown))
 For Each oa In ob
 If oa.Value = "Ouvidoria" Then
 With oa
 .Offset(0, -1).Value = oa.Value
 .Offset(0, 8).Value = "NA"
 .Offset(0, 9).Value = "NA"
 .Offset(0, 10).Value = "DEPÓSITO"
 End With
 End If
 Next
 Dim pa, pb, p1, p2 As Range
 Set p1 = Columns("H:H").SpecialCells(xlCellTypeBlanks)
 For Each pa In p1
 pa.Value = "Estoque"
 Next
 Set p2 = Range(Range("H2"), Range("H2").End(xlDown))
 For Each pb In p2
 If pb.Value = "Estoque" Then pb.Offset(0, -7).Value = pb.Value
 Next
 Dim k1, k2, k3, k4, k5, ka, kb, kaa, kbb As Range
 Set k1 = Range(Range("A2"), Range("A2").End(xlDown))
 Set k2 = Range(Range("C2"), Range("C2").End(xlDown))
 Set k3 = Range(Range("G2"), Range("G2").End(xlDown))
 Set k4 = Range(Range("K2"), Range("K2").End(xlDown))
 Set k5 = Range(Range("N2"), Range("N2").End(xlDown))
 Set ka = Union(k1, k2)
 Set kb = Union(k3, k4, k5)
 
 For Each kaa In ka
 kaa.Value = StrConv(kaa.Value, vbProperCase)
 Next kaa
 For Each kbb In kb
 kbb.Value = UCase(kbb.Value)
 Next kbb
End Sub
Private Sub ReplaceSomeCharacters (ParamArray colLtrs() As Variant)
 
 Dim rangeOfInterest As Range
 Dim cLtr As Variant
 For Each cLtr In colLtrs
 Set rangeOfInterest = Range(Range(cLtr & "2"), Range(cLtr & "2").End(xlDown))
 With rangeOfInterest
 .Replace What:=".", Replacement:=""
 .Replace What:="/", Replacement:=""
 .Replace What:=":", Replacement:=""
 .Replace What:="–", Replacement:="-"
 End With
 Next
End Sub
Private Sub ClearNonNumerics(ByVal eRow As Long, ParamArray rangeExpressions() As Variant)
 Dim tc As String
 Dim td As String
 Dim te As String
 Dim t As Long
 Dim rangeOfInterest As Range
 Dim rangeExpression As Variant
 For Each rangeExpression In rangeExpressions
 Set rangeOfInterest = Range(rangeExpression & eRow)
 tc = ""
 For t = 1 To Len(rangeOfInterest.Value)
 td = Mid(rangeOfInterest.Value, t, 1)
 If td Like "[0-9]" Then
 te = td
 Else
 te = ""
 End If
 tc = tc & te
 Next t
 
 rangeOfInterest .Value = tc
 Next
End Sub

To find where your code's performance is poor with some precision, you can add a small subroutine like:

Sub MarkTime(ByVal locationIdentifier As String)
 Debug.Print Now() & " :" & locationIdentifier
End Sub

Calling this subroutine from the entrance and exit of all subroutines will print timestamps with 1 second resolution. The output can be evaluated to find the slowest blocks of code.

• Cameron Critchlow: This is beautiful.

Answer 2

Diagnosing bad code performance is actually not too hard once you know the standard approach. It comes down to two (maybe three) things:

1. Identify which sections of the code are slow
2. Work out why they are slow (often from a standard set of reasons)
3. (Fix it - often from a standard set of fixes)

1. Identify which sections of the code are slow

There are two ways to do this. The first, if you have no idea whatsoever, you profile your code. Profiling can be very simple:

Sub slowCode()
 Dim startTime As Single
 startTime = Timer
 process_one 'do something
 Debug.Print "Reached location one at t="; Timer - startTime
 process_two 'do something else
 Debug.Print "Reach location two at t="; Timer - startTime
 For i = 1 to 5
 process_three 'do something in a loop
 Next i
 Debug.Print "Reached End at t="; Timer - startTime
End Sub

That might output

Reached location one at t=0.1223
Reached location two at t=7.342 '<---This looks like the slow step location 1->2
Reached End at t=7.554

For complex situations you can reach for a profiling library like the one I wrote. But often debug.print a few timestamps allows you to find the really slow bit.

The second method, which you can see in the comments, is to use a "rule of thumb" or educated guess, which for VBA - a language used to process spreadsheet data - the rule of thumb is to look for nested For/For Each loops (i.e., a loop within a loop) that iterate over cells in the worksheet, and assume that is the slow part of the code. If that sounds hand-wavy it's because it is; method 1 is always going to be more precise. But surprisingly, it's not that bad. Let me explain a little why it works:

VBA is a slow uncompiled language compared to C++ or something, but really it's not that slow, used correctly it can write blazingly fast applications. For that reason, typically we find that the code we write is pretty instantaneous for a small range of cells, it's only when we increase to a larger set of data that things become unbearably slow. That's where For loops come in. Consider this made-up code:

Sub DoAThing(ByVal data As Range)
 'process_1
 Debug.Print "Number of cells = "; data.Rows.Count * data.Columns.Count
 'process 2
 Dim cell As Range
 For Each cell In data
 cell.Value = 420
 Next cell
End Sub

It is important to notice two things:

1. The whole Sub DoAThing can be split into two distinct sections:

   • The first section that calculates the number of cells by multiplication
   • The second section which is a loop over the cells in the dataset

2. For the first process it does not matter how big data is and how many cells are in it. The operation will take the same amount of time regardless, because obtaining the dimensions of a big rectangle is just as easy/difficult as obtaining the dimensions of a little rectangle. In contrast, for process 2 it does matter how big data is. In fact, the more cells are in the dataset, the longer it will take to change the value in every one of them*.

*It'll actually be proportional, double the number of cells and you expect it to take twice as long.

---

Now, imagine running this Sub over just a few cells. It would run in the blink of an eye, both process 1 and 2 would take basically 0 seconds. But what happens if we do this over a really big dataset? Which process would be the culprit for the Sub taking a long time?

The second one of course, since it gets slower and slower as the data grows, so if we want to speed things up we can basically ignore process 1 and focus purely on process 2. This logic extends further. If we have this code:

Sub DoSomeNestedLoops(ByVal data As Range)
 'process 1
 Dim cell As Range
 For Each cell In data
 doASlowThing
 Next cell
 'process 2
 Dim cell1 As Range, cell2 As Range
 For Each cell1 In data
 For Each cell2 In data
 doAFastThing
 Next cell2
 Next cell1
End Sub

Now process 2 has a nested For loop. This means if there are 10 cells in the dataset, we will call doAFastThing 10*10=100 times!

So of course for a really big dataset process 2 is going to be the slow part. There's a subtle point here though: for 10 cells of data, in process 1 we call doASlowThing 10 times, and in process 2 we call doAFastThing 100 times. Actually process 1 might still take longer in total for a small number of cells, if 10*slow > 100*fast. However, we can be sure, if we have 1000 or 1 million cells, process 2 will start to dominate.

Hmm, this rule of thumb is getting complicated, and in fact there's a lot more to talk about here (algorithmic complexity, big O notation, vectorisation, etc.) so I'll leave it there and say that if in doubt method 1 (profiling) will always work, and method 2 of spotting the nested loops is a good approximation for when big data is at play, but only experience will give you the same level of intuition as some of the commenters on this (just look how many internet points they have!).

2. Work out why they are slow (often from a standard set of reasons)

So we found the slow bit of code that needs to be optimised (the rest we can ignore). Here's why code might be slow specifically in Excel VBA:

• Reading data from the sheet to VBA one cell at a time rather than all in one go.
• Writing data from VBA to the sheet 1 cell at a time, forcing the screen to repaint, forcing worksheet functions to calculate over and over again .
• Performing complicated mathematical operations in VBA (uncompiled, single thread) rather than using worksheet functions (compiled, multi-thread) or a VBA library
• Selecting or Activateing sheets and ranges rather than referring to them directly by name (you don't make this mistake)
• That's basically it to be honest, as far as typical Excel VBA use cases go.

There are more advanced ones related to memory allocation, using the appropriate data structures, and other quirks like autosave. That's what Code Review is for, so well done for posting:)

(3. Standard fixes)

Those standard problems all have pretty standard fixes

• Rather than looping over cells when reading or writing, read/write an array of data only once and do the looping in VBA
• If you must perform multiple writes to the worksheet, then turn off automatic calculations, screen updates, freezpanes etc. If you write only once then this will not be an issue.
• Use named ranges and worksheet functions more! VBA is designed to integrate really closely with Excel, so my VBA apps generally do most of the calculating in the worksheet, and just a bit of automation from VBA. Why not make a template worksheet with all formatting and headers, copy the data in then copy+paste values to freeze the result?

Code

This is a short demo of the diagnosing performance issues approach for your code. To do this, first split your code into blocks to identify the most deeply nested portion with respect to the amount of data you run it on:

Sub a_organizar_protocolo()
 On Error Resume Next
 Application.DisplayFormulaBar = False
 Application.ScreenUpdating = False
 Application.Calculation = xlCalculationManual
 Application.EnableEvents = False
 Application.InterActive = False
 ActiveWorkbook.Save
 ActiveSheet.AutoFilterMode = False
 ActiveWindow.Zoom = 90
 Columns("O:P").ClearContents
 Columns("R:R").ClearContents
 With Cells
 .VerticalAlignment = xlCenter
 .HorizontalAlignment = xlCenter
 .Borders(xlDiagonalDown).LineStyle = xlNone
 .Borders(xlDiagonalUp).LineStyle = xlNone
 .WrapText = False
 .Orientation = 0
 .AddIndent = False
 .IndentLevel = 0
 .ShrinkToFit = False
 .ReadingOrder = xlContext
 .MergeCells = False
 With .Borders
 .LineStyle = xlContinuous
 .ColorIndex = 0
 .Weight = xlThin
 End With
 With .Font
 .Name = "Calibri"
 .Size = 11
 .ColorIndex = xlAutomatic
 .Bold = False
 .Italic = False
 End With
 End With
 With Rows("1:1")
 .RowHeight = 32
 .Interior.ColorIndex = 49
 .WrapText = True
 With .Font
 .Size = 12
 .Bold = True
 .ColorIndex = 44
 End With
 End With
 With ActiveWindow
 .FreezePanes = False
 .SplitColumn = 0
 .SplitRow = 1
 .FreezePanes = True
 End With
 With Rows("2:" & Rows.Count)
 .RowHeight = 15
 .Interior.Color = xlNone
 End With
 Columns("A:A").ColumnWidth = 15
 Columns("B:B").ColumnWidth = 14
 Columns("C:C").ColumnWidth = 20
 Columns("D:D").ColumnWidth = 30
 Columns("E:E").ColumnWidth = 14
 Columns("F:F").ColumnWidth = 11
 Columns("G:G").ColumnWidth = 40
 Columns("H:H").ColumnWidth = 14
 Columns("I:I").ColumnWidth = 14
 Columns("J:J").ColumnWidth = 16
 Columns("K:K").ColumnWidth = 20
 Columns("L:L").ColumnWidth = 10
 Columns("M:M").ColumnWidth = 8
 Columns("N:N").ColumnWidth = 12
 Columns("O:O").ColumnWidth = 5
 Columns("P:P").ColumnWidth = 14
 Columns("Q:R").ColumnWidth = 25
 Range("A1").Value = "Lançamento"
 Range("B1").Value = "Data de Recebimento"
 Range("C1").Value = "Solicitante"
 Range("D1").Value = "Espécie do Documento"
 Range("E1").Value = "Número da Nota Fiscal"
 Range("F1").Value = "Código do Fornecedor"
 Range("G1").Value = "Fornecedor"
 Range("H1").Value = "Centro de Custo"
 Range("I1").Value = "Vencimento"
 Range("J1").Value = "Valor"
 Range("K1").Value = "Descrição"
 Range("L1").Value = "Pedido"
 Range("M1").Value = "Item do Pedido"
 Range("N1").Value = "Pagamento"
 Range("O1").Value = "Validação"
 Range("P1").Value = "Prioridade"
 Range("Q1").Value = "Observação"
 Range("R1").Value = "Concatenar"

All that is fine and works in constant time (independent of the number of cells of data). It's not making your code slow I don't think.

---

 Dim qa, q1, q2, q3 As Range
 Set q1 = Range(Range("G2"), Range("G" & Rows.Count))
 Set q2 = Range(Range("J2"), Range("K" & Rows.Count))
 Set q3 = Range(Range("Q2"), Range("R" & Rows.Count))
 Set qa = Union(q1, q2, q3)
 qa.HorizontalAlignment = xlLeft
 Dim ea, e1, e2 As Range
 Set e1 = Range(Range("G2"), Range("G2").End(xlDown))
 Set e2 = Range(Range("K2"), Range("K2").End(xlDown))
 Set ea = Union(e1, e2)
 With ea
 .Replace What:=".", Replacement:=""
 .Replace What:="/", Replacement:=""
 .Replace What:=":", Replacement:=""
 .Replace What:="–", Replacement:="-"
 End With

This code's performance scales linearly with the number of rows in your dataset. However, you don't loop, but use the .Replace function which is clever. It'll still get twice as slow if you have twice as many rows, but you delegate the looping to Excel (compiled) rather than looping in VBA (uncompiled), so you make each iteration of the loop faster.

---

 Dim r0, ra As Range
 Set r0 = Range(Range("E2"), Range("E2").End(xlDown))
 For Each ra In r0
 If Len(ra.Value) > 9 Then ra.Value = Right(ra.Value, 9)
 Next
 r0.Replace What:="x", Replacement:="0"

Scales linearly with number of rows, as above.

---

 Dim ta, tb As Range
 Dim t1, t2, t3, t4 As Range
 t0 = Range("E:E").SpecialCells(xlCellTypeLastCell).Row
 Set t1 = Range("E2:E" & t0)
 Set t2 = Range("F2:F" & t0)
 Set t3 = Range("H2:H" & t0)
 Set t4 = Range("L2:M" & t0)
 Set tb = Union(t1, t2, t3, t4)
 For Each ta In tb
 tc = ""
 For t = 1 To Len(ta.Value)
 td = Mid(ta.Value, t, 1)
 If td Like "[0-9]" Then
 te = td
 Else
 te = ""
 End If
 tc = tc & te
 Next t
 ta.Value = tc
 Next
 Dim ya, yb As Range
 Set yb = Range(Range("J2"), Range("J2").End(xlDown))
 For Each ya In yb
 yc = ""
 For y = 1 To Len(ya.Value)
 yd = Mid(ya.Value, y, 1)
 If yd Like "[0-9],-" Then
 ye = yd
 Else
 ye = ""
 End If
 yc = yc & ye
 Next y
 ya.Value = yc * 1
 Next

Both these loops scale linearly with the number of rows, but then also linearly with the average length of text in each cell. You also work on 5 columns, this is slow. For N rows of data you write to the sheet 5N times.

---

 Dim ia, ib As Range
 Set ib = Range(Range("J2"), Range("J2").End(xlDown))
 For Each ia In ib
 If ia.Value < 0 Then
 With ia
 .Offset(0, -1).Value = "31/12/" & (Year(Date) + 1)
 .Offset(0, -2).Value = "NA"
 .Offset(0, 2).Value = "NA"
 .Offset(0, 3).Value = "NA"
 End With
 End If
 Next
 Dim oa, ob As Range
 Set ob = Range(Range("D2"), Range("D2").End(xlDown))
 For Each oa In ob
 If oa.Value = "Ouvidoria" Then
 With oa
 .Offset(0, -1).Value = oa.Value
 .Offset(0, 8).Value = "NA"
 .Offset(0, 9).Value = "NA"
 .Offset(0, 10).Value = "DEPÓSITO"
 End With
 End If
 Next

With those offsets you write to the sheet 8N times for N rows of data.

 Dim pa, pb, p1, p2 As Range
 Set p1 = Columns("H:H").SpecialCells(xlCellTypeBlanks)
 For Each pa In p1
 pa.Value = "Estoque"
 Next
 Set p2 = Range(Range("H2"), Range("H2").End(xlDown))
 For Each pb In p2
 If pb.Value = "Estoque" Then pb.Offset(0, -7).Value = pb.Value
 Next
 Dim k1, k2, k3, k4, k5, ka, kb, kaa, kbb As Range
 Set k1 = Range(Range("A2"), Range("A2").End(xlDown))
 Set k2 = Range(Range("C2"), Range("C2").End(xlDown))
 Set k3 = Range(Range("G2"), Range("G2").End(xlDown))
 Set k4 = Range(Range("K2"), Range("K2").End(xlDown))
 Set k5 = Range(Range("N2"), Range("N2").End(xlDown))
 Set ka = Union(k1, k2)
 Set kb = Union(k3, k4, k5)
 For Each kaa In ka
 kaa.Value = StrConv(kaa.Value, vbProperCase)
 Next kaa
 For Each kbb In kb
 kbb.Value = UCase(kbb.Value)
 Next kbb

These loops are all linear with number of rows of data.

---

Because all loops are linear with data size, no single operation will dominate as the data gets larger (well, that first block of code is constant time, so it shouldn't dominate performance as the data grows). Therefore you need to profile these loops to find which is actually slow.

---

BTW: This Dim k1, k2, k3, k4, k5, ka, kb, kaa, kbb As Range doesn't do what you think it does. kbb gets declared as Range, but all the others are implicitly Variant. You need Dim k1 As Range, k2 As Range, ... kbb As Range, at which point you may as well split over multiple lines.

• eirikdaude: VBA is compiled to Microsoft P-code, it is not an uncompiled language - not that it affects your answer a lot.
• Cristian Buse: @eirikdaude You are partially correct. Compiling to P-code it just an intermediary step because P-code gets interpreted by a virtual machine. So, VBA is not compiled overall which makes it slower than compiled languages like C.
• eirikdaude: @CristianBuse Would you likewise argue that e.g. Java isn't a compiled language, because the bytecode it's compiled to is interpreted by a virtual machine?
• Doc Brown: @eirikdaude: it is not that simple. VBA's bytecode interpreter isn't famous for being very fast, especially in comparison to the common Java bytecode JIT compilers. However, VBA program's are usually running directly in-process with Excel, which sometimes give a noteable performance benefit in comparision to an equivalent out-of-process approach, which most Java programs would require for controlling Excel.
• eirikdaude: Yes, but my point of contention isn't whether it is fast or not, but whether it is correct to say the code isn't compiled. Tbh. I am not familiar enough with the implementation of either the java vm or microsoft's to say how significant their differences are. I do note that both java and vba are noted as examples of languages compiled to p-code on the wikipedia page for that though. It's a minor point anyway, which doesn't alter the answer in any significant way. @DocBrown