O que fazer para essa macro nao deixar a planilha lenta

Question

Essa macro está deixando meu arquivo lento.. O que pode ser feito?

Private Sub Worksheet_Change(ByVal Target As Range)
    If Target.Cells.Count > 1 Then
        Exit Sub
    End If
    On Error GoTo ErrHandler:
       'Letra Primeira Maiuscula
    If Not Application.Intersect(Application.Union(Range("m4:m2002"), Range("l4:l2002"), Range("n4:n2002"), Range("u4:u2002")), Target) Is Nothing Then
        
        If Not IsNumeric(Target.Value) Then
            Application.EnableEvents = False
            Target.Value = TitleCase(Target.text)
            Application.EnableEvents = True
        End If
          
    End If
    
     Application.EnableEvents = True
     
     'Letras Maiusculas
     If Target.Column = 6 Or Target.Column = 7 Or Target.Column = 11 Or Target.Column = 15 Then
            If Not (Target.text = UCase(Target.text)) Then
               Target = UCase(Target.text)
        End If
    End If
    
ErrHandler:
    Application.EnableEvents = True
   
End Sub

Function TitleCase(text As String) As String
    Dim doc As Object
    Dim sentence, word, w
    Dim i As Long, j As Integer
    Dim arrLowerCaseWords
    
    arrLowerCaseWords = Array("a", "as", "ao", "do", "da", "das", "de", "do", "dos", "para", "em", "na", "nas", "no", "à", "o", "e", "é", _
                              "ou", "com", "sem", "desde", "até", "pelo", "por", "não", "como", "um", "uma", "uns", "são", "mas")
    
    text = Application.WorksheetFunction.Proper(text)
    
    Set doc = CreateObject("Word.Document")
    
    doc.Range.text = text
    
    For Each sentence In doc.Sentences
        For i = 2 To sentence.Words.Count
            If sentence.Words.Item(i - 1) <> """" Then
                Set w = sentence.Words.Item(i)
                For Each word In arrLowerCaseWords
                    If LCase(Trim(w)) = word Then
                        w.text = LCase(w.text)
                    End If
                    
                    j = InStr(w.text, "'")
                    
                    If j Then w.text = Left(w.text, j) & LCase(Right(w.text, Len(w.text) - j))
                    
                Next
            End If
        Next
    Next
    
    TitleCase = doc.Range.text
    
    doc.Close False
    Set doc = Nothing
End Function

Answer 1

BárbaraBettanin,

    deixa eu ver se entendi sobre a função "TitleCase"...
    ... essa função precisa converter tudo que está no intervalo:
    - "... Range("m4:m2002"), ..."

    Em texto com a primeira letra em maiúscula, com exceção das conjunções... é isso?

    talvez seja possível customizar essa função para que não entre em três rotinas "FOR" aninhadas...

    Achei sua função aqui: 

=======================================
Proper Case with extra rules in Excel

https://stackoverflow.com/questions/39569861/proper-case-with-extra-rules-in-excel
=======================================

     Algumas dicas:

=======================================
MS Excel: How to use the STRCONV Function (VBA)

https://www.techonthenet.com/excel/formulas/strconv.php
=======================================
Convert to Proper Case

https://www.excel-easy.com/vba/examples/convert-to-proper-case.html
=======================================
Evento Worksheet.Change (Excel)
Ocorre quando as células da planilha são alteradas pelo usuário ou por um link externo.

https://msdn.microsoft.com/pt-br/vba/excel-vba/articles/worksheet-change-event-excel?f=255&MSPPError=-2147217396
=======================================
Proper case on Excel VBA: How to add a rule and apply the function on entire worksheet

https://stackoverflow.com/questions/39898804/proper-case-on-excel-vba-how-to-add-a-rule-and-apply-the-function-on-entire-wor
=======================================
VBA Excel - changing case to Proper Case

Sub test()

Dim Lastrow As Integer
Dim range As range
Dim c As range

With Worksheets("Overdue PO")
Lastrow = Columns("D:F").Cells.Find(What:="*", LookIn:=xlValues,   SearchOrder:=xlByColumns, SearchDirection:=xlPrevious).Row
    .range("D2:F" & Lastrow).Select
    Set range = Selection
End With

For Each c In range
    c.Value = Application.WorksheetFunction.Proper(c.Value)
Next c

End Sub

https://stackoverflow.com/questions/36601733/vba-excel-changing-case-to-proper-case
=======================================
Rules for Capitalization in Titles of Articles

http://grammar.yourdictionary.com/capitalization/rules-for-capitalization-in-titles.html
=======================================


[]'s,
Fabio I.