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.
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. \$\endgroup\$Range(Range("E2"), Range("E2"))is exactly equivalent toRange("E2"); worksheet reads/writes need to be limited to achieve better performance. \$\endgroup\$taloop is iterating every single row across 4 columns, one by one: I suspect that's where more of the time is being spent. \$\endgroup\$