Notifications
Clear all

Extensões que salvam em macro/ tirar acentos

3 Posts
2 Usuários
0 Reactions
1,020 Visualizações
leonder
(@leonder)
Posts: 180
Reputable Member
Topic starter
 

Pessoal, eu utilizo esse macro para tirar todo os acentos das células que eu quero...

perguntas:

1-qual o método mais fácil de eu salvar meu arquivo do excel na qual eu possa abrir depois e esteja o macro funcionando?
2-existe alguma função que substitua este macro?

Function TiraAcento(Palavra)

    CAcento = "àáâãäèéêëìíîïòóôõöùúûüÀÁÂÃÄÈÉÊËÌÍÎÒÓÔÕÖÙÚÛÜçÇñÑ"
    SAcento = "aaaaaeeeeiiiiooooouuuuAAAAAEEEEIIIOOOOOUUUUcCnN"
    Texto = ""
    
    If Palavra <> "" Then
        For X = 1 To Len(Palavra)
            Letra = Mid(Palavra, X, 1)
            Pos_Acento = InStr(CAcento, Letra)
            If Pos_Acento > 0 Then
                Letra = Mid(SAcento, Pos_Acento, 1)
            End If
            Texto = Texto & Letra
        Next
        TiraAcento = Texto
    End If
    
End Function


Function VerificaPalavra(atributo)
Dim i
Dim id
Dim Auxiliar
Dim Resultado

    Auxiliar = Split(atributo, " ", -1, vbBinaryCompare)

    For i = LBound(Auxiliar) To UBound(Auxiliar)
        Resultado = Resultado & " " & TiraAcento(Auxiliar(i))
    Next

    VerificaPalavra = Trim(Resultado)
End Function
 
Postado : 07/04/2015 8:05 am
Fernando Fernandes
(@fernandofernandes)
Posts: 43750
Illustrious Member
 

Bom dia leonder

Você tem que salvar como Pasta de Trabalho Habilitada para Macro do Excel.
Não existe uma função nativa do Excel que faça isso.

Se a dica foi útil, clique na mãozinha que fica do lado da ferramenta Citar.

[]s

Existem mil maneiras de preparar Neston. Invente a sua!
http://www.youtube.com/ExpressoExcel

 
Postado : 07/04/2015 8:33 am
Fernando Fernandes
(@fernandofernandes)
Posts: 43750
Illustrious Member
 

Eu acho que aí tem muito código pra pouca coisa...

Uma função está quebrando as palavras e chamando a remoção de acentos para cada palavra, quando isso é totalmente desnecessário...

A outra função, ok, não é ruim verificar a existência do acento antes de substituí-lo, mas, considerando o poder das máquinas de hoje, a velocidade de processamento, e que estamos lidando somente com variáveis em memória, essa verificação é desnecessária.

Eu mudei o código para usar duas matrizes unidimensionais simples e então um loop simples na matriz, fica assim:

Function TirarAcento1(Texto)
Dim ComAcento   As Variant
Dim SemAcento   As Variant
Dim i           As Long

    ComAcento = Array("à", "á", "â", "ã", "ä", "è", "é", "ê", "ë", _
                      "ì", "í", "î", "ï", "ò", "ó", "ô", "õ", "ö", _
                      "ù", "ú", "û", "ü", "À", "Á", "Â", "Ã", "Ä", _
                      "È", "É", "Ê", "Ë", "Ì", "Í", "Î", _
                      "Ò", "Ó", "Ô", "Õ", "Ö", "Ù", "Ú", "Û", "Ü", _
                      "ç", "Ç", "ñ", "Ñ")
    SemAcento = Array("a", "a", "a", "a", "a", "e", "e", "e", "e", _
                      "i", "i", "i", "i", "o", "o", "o", "o", "o", _
                      "u", "u", "u", "u", "A", "A", "A", "A", "A", _
                      "E", "E", "E", "E", "I", "I", "I", _
                      "O", "O", "O", "O", "O", "U", "U", "U", "U", _
                      "c", "C", "n", "N")
    For i = LBound(ComAcento, 1) To UBound(ComAcento, 1)
        Texto = VBA.Replace(Texto, ComAcento(i), SemAcento(i), 1, -1, vbBinaryCompare)
    Next i
    TirarAcento1 = Texto
    
End Function

Outra opção interessante pois usa dicionário (precisa incluir a referência ao Microsoft Scripting Runtime), seria:

Function TirarAcento2(Texto)
Dim dicAcentos  As New Scripting.Dictionary
Dim keyAcentos  As Variant
Dim ComAcento   As Variant
Dim SemAcento   As Variant
Dim Letra       As String
Dim i           As Long

    ComAcento = Array("à", "á", "â", "ã", "ä", "è", "é", "ê", "ë", _
                      "ì", "í", "î", "ï", "ò", "ó", "ô", "õ", "ö", _
                      "ù", "ú", "û", "ü", "À", "Á", "Â", "Ã", "Ä", _
                      "È", "É", "Ê", "Ë", "Ì", "Í", "Î", _
                      "Ò", "Ó", "Ô", "Õ", "Ö", "Ù", "Ú", "Û", "Ü", _
                      "ç", "Ç", "ñ", "Ñ")
    SemAcento = Array("a", "a", "a", "a", "a", "e", "e", "e", "e", _
                      "i", "i", "i", "i", "o", "o", "o", "o", "o", _
                      "u", "u", "u", "u", "A", "A", "A", "A", "A", _
                      "E", "E", "E", "E", "I", "I", "I", _
                      "O", "O", "O", "O", "O", "U", "U", "U", "U", _
                      "c", "C", "n", "N")
    For i = LBound(ComAcento, 1) To UBound(ComAcento, 1)
        dicAcentos.Add ComAcento(i), SemAcento(i)
    Next i
    For i = 1 To VBA.Len(Texto)
        Letra = VBA.Mid(Texto, i, 1)
        If dicAcentos.Exists(Letra) Then
            Texto = VBA.Replace(Texto, Letra, dicAcentos(Letra), 1, -1, vbBinaryCompare)
        End If
    Next i

    TirarAcento2 = Texto
    
End Function

Ambas funcionam. A primeira é mais simples, a segunda considera teste para existência do acento antes de substituí-lo. A segunda faz melhor o que a sua faz pois é mais rápida. É mais rápida pq usa dicionário ao invés do VBA.Instr().

Enfim, pode usar qquer das duas.

Qto a suas perguntas:
1) O método mais fácil? Você tem que salvar como XLSM e esse código precisa estar em todos os arquivos em que vc usa essa função UDF (user defined function). A alternativa seria criar um suplemento ou salvá-la na pasta Pessoal.xlsm de macros. Assim fica disponível para todos seus arquivos abertos, sejam XLSX, XLS, etc. A desvantagem é que só funcionará no seu computador.

2) Até o Excel 2013, não existe função para remoção de caracteres com acentos.

Existem mil maneiras de preparar Neston. Invente a sua!
http://www.youtube.com/ExpressoExcel

 
Postado : 07/04/2015 8:34 am