Retirar os acentos de Planilhas, Textos, Apresentações, Bases de Dados, etc....eventualmente também é necessário, seguem códigos úteis para serem colados no seu Editor VBA:
Function removeAcentos (ByVal texto As String) As String
Dim vPos As Byte
Const vComAcento = "ÀÁÂÃÄÅÇÈÉÊËÌÍÎÏÒÓÔÕÖÙÚÛÜàáâãäåçèéêëìíîïòóôõöùúûü"
Const vSemAcento = "AAAAAACEEEEIIIIOOOOOUUUUaaaaaaceeeeiiiiooooouuuu"
For i = 1 To Len(texto)
vPos = InStr(1, vComAcento, Mid(texto, i, 1))
If vPos > 0 Then
Mid(texto, i, 1) = Mid(vSemAcento, vPos, 1)
End If
Next
removeAcentos = texto
End Function
Private Sub Command1_Click()
'exemplo de como chamar
Text1 = removeAcentos(Text1)
End Sub
Outra opção:
Sub Substituir()
Cells.Replace What:="é", Replacement:="e", LookAt:=xlPart, SearchOrder:=xlByRows, MatchCase:=False, SearchFormat:=False, ReplaceFormat:=False
Cells.Replace What:="É", Replacement:="E", LookAt:=xlPart, SearchOrder:=xlByRows, MatchCase:=False, SearchFormat:=False, ReplaceFormat:=False
Cells.Replace What:="á", Replacement:="a", LookAt:=xlPart, SearchOrder:=xlByRows, MatchCase:=False, SearchFormat:=False, ReplaceFormat:=False
Cells.Replace What:="Á", Replacement:="A", LookAt:=xlPart, SearchOrder:=xlByRows, MatchCase:=False, SearchFormat:=False, ReplaceFormat:=False
End Sub
Uma ampliação do código em:
Public Function DLTiraAcentos(ByVal strOriginal As String)
'By JPaulo @ 2009
Dim strToReturn As String
strToReturn = ""
Dim i As Integer
For i = 1 To Len(strOriginal)
strToReturn = strToReturn & DLTiraAcentos_GetCorrectChar(Mid$(strOriginal, i, 1))
Next i
DLTiraAcentos = strToReturn
End Function
Public Function DLTiraAcentos_GetCorrectChar(ByVal strChar As String) As String
Dim LetrasComAcentos As String
Dim LetrasSemAcentos As String
LetrasComAcentos = "ÁÍÓÚÉÄÏÖÜËÀÌÒÙÈÃÕÂÎÔÛÊáíóúéäïöüëàìòùèãõâîôûêÇç"
LetrasSemAcentos = "AIOUEAIOUEAIOUEAOAIOUEaioueaioueaioueaoaioueCc"
Dim i As Integer
For i = 1 To Len(LetrasComAcentos)
If strChar = Mid$(LetrasComAcentos, i, 1) Then
DLTiraAcentos_GetCorrectChar = Mid$(LetrasSemAcentos, i, 1)
Exit Function
End If
Next
DLTiraAcentos_GetCorrectChar = strChar
End Function
A criatividade é uma dádiva:
Function Sem_Acento(Acento)
'Desclara variável
Dim tmp$
tmp = Trim(Acento)
For i = 1 To Len(tmp)
x = Asc(Mid(tmp, i, 1))
Select Case x
Case 192 To 197: x = "A"
Case 200 To 203: x = "E"
Case 204 To 207: x = "I"
Case 209: x = "N"
Case 210 To 214: x = "O"
Case 217 To 220: x = "U"
Case 221: x = "Y"
Case 224 To 229: x = "a"
Case 232 To 235: x = "e"
Case 236 To 239: x = "i"
Case 241: x = "n"
Case 240, 242 To 246: x = "o"
Case 249 To 252: x = "u"
Case 253, 255: x = "y"
Case Else: x = Chr(x)
End Select
Sem_Acento = Sem_Acento & x
Next
End Function '
Tags: VBA, dica, trick, tip, acento, diacrítico, retirar
