VBA Tips - Removendo caracteres especiais de uma palavra - Remove and replace special characters



Ao processar um arquivo XML a partir da web tive alguns caracteres especiais, parecidos aos mostrados abaixo, mas o analisador MSXML recusou-se a aceitá-los. Precisaram ser convertidos ao normal (ou seja, sem sotaque) antes que possam ser analisados pelo XML.



Referio-me aos caracteres acentuados que se parecem com isto: é, ñ, André.

Aqui está uma ligeira adaptação do código. Basta passar como parâmetro qualquer seqüência que desejar expurgar; quaisquer caracteres estranhos serão substituídos por seus equivalentes não-acentuados. Poderá usar este código como uma Função VBA numa planilha, bem como em outros aplicativos da suíte MS Office.

Este código tem algumas pequenas variações, por exemplo, em vez de sempre efetuar um loop através da lista de caracteres acentuados, ele percorre a cadeia de entrada que for mais curta. 


Function ConvertAccent (ByVal inputString As String) As String
Const AccChars As String = _
    "ŠŽšžŸÀÁÂÃÄÅÇÈÉÊËÌÍÎÏÐÑÒÓÔÕÖÙÚÛÜÝàáâãäåçèéêëìíîïðñòóôõöùúûüýÿ"
Const RegChars As String = _
    "SZszYAAAAAACEEEEIIIIDNOOOOOUUUUYaaaaaaceeeeiiiidnooooouuuuyy"
Dim i As Long, j As Long
Dim tempString As String
Dim currentCharacter As String
Dim found As Boolean
Dim foundPosition As Long
  Let tempString = inputString
  ' loop through the shorter string

  Select Case True
    Case Len(AccChars) <= Len(inputString)
      ' accent character list is shorter (or same)
      ' loop through accent character string
      For i = 1 To Len(AccChars)
        ' get next accent character
        Let currentCharacter = Mid$(AccChars, i, 1)
        ' replace with corresponding character in "regular" array
        If InStr(tempString, currentCharacter) > 0 Then
          Let tempString = Replace(tempString, currentCharacter, Mid$(RegChars, i, 1))
        End If
      Next i
    Case Len(AccChars) > Len(inputString)
      ' input string is shorter
      ' loop through input string
      For i = 1 To Len(inputString)
        ' grab current character from input string and
        ' determine if it is a special char
        Let currentCharacter = Mid$(inputString, i, 1)
        Let found = (InStr(AccChars, currentCharacter) > 0)
        If found Then
          ' find position of special character in special array
          Let foundPosition = InStr(AccChars, currentCharacter)
          ' replace with corresponding character in "regular" array
          Let tempString = Replace(tempString, currentCharacter, _
    Mid$(RegChars, foundPosition, 1))
        End If
      Next i
  End Select
  Let ConvertAccent = tempString
End Function

Se a lista de caracteres acentuados for mais curta (o cenário mais provável), então dê um nó laço com ele e dê a cada carácter a uma variável String. Se existir na cadeia de entrada, o caractere acentuado será substituído com o carácter na lista de seqüência regular, mesmo se ele for encontrado várias vezes (a função Replace). Portanto, independentemente do tamanho da cadeia de entrada, o circuito só será executada 60 vezes (o número de caracteres acentuados) por String.

Se a lista de caracteres acentuados for maior, então ocorrerá um loop através da cadeia de entrada. Cada carácter será pego e atribuído a uma variável String. Se for encontrado na lista de caracteres acentuados, será substituído com o caractere correspondente na lista de cadeia normal. Mesmo que a lista de caracteres acentuados contenha 60 caracteres, o loop só irá executar n vezes (o número de caracteres na cadeia de entrada).

Segue um código variante:

Function ConvertAccent2 (ByVal inputString As String) As String
  Dim X As Long, Position As Long

  Const AccChars As String = _
        "ŠŽšžŸÀÁÂÃÄÅÇÈÉÊËÌÍÎÏÐÑÒÓÔÕÖÙÚÛÜÝàáâãäåçèéêëìíîïðñòóôõöùúûüýÿ"
  Const RegChars As String = _
        "SZszYAAAAAACEEEEIIIIDNOOOOOUUUUYaaaaaaceeeeiiiidnooooouuuuyy"

  For X = 1 To Len(inputString)
    Let Position = InStr(AccChars, Mid(inputString, X, 1))

    If Position Then Mid(inputString, X) = Mid(RegChars, Position, 1)
  Next

  Let ConvertAccent = inputString
End Function

Tags: VBA, XML, Tips, rename, caracter, character, acentuado, MSXML

Nenhum comentário:

Postar um comentário

diHITT - Notícias