none
O que fazer para essa macro nao deixar a planilha lenta RRS feed

  • Pergunta

  • 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
    
    

    quinta-feira, 30 de agosto de 2018 19:25

Todas as Respostas

  • 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.
    sexta-feira, 31 de agosto de 2018 12:56