[Resolvido]Limpa Acentos, caracteres especiais e espaços em um só módulo

Srs
Bom dia!

Estou precisando da preciosa e habitual ajuda dos senhores
Tenho um banco chamado "Base" e nele uma tabela "Físico" e nessa tabela um campo "Descrição"
Essa tabela possui mais ou menos 360.000 registros e o que preciso é um módulo que tire os acentos, caracteres especiais e espaços extras de uma só vez no campo "descrição".
Se puderem me ajudar ficarei imensamente grato

Ola Carlão,

Seguem 2 funções onde você pode COPIAR+COLAR em algum módulo qualquer:

Código:



Public Function fncRemCaracSpc(ByVal nCampo As Variant) As String
Dim carac1          As String
Dim carac2          As String
Dim x              As Integer
   
    If IsNull(nCampo) Or Trim(nCampo) = "" Then
        fncRemCaracSpc = ""
        Exit Function
    End If
   
    '-- Inclua quais os caracteres especiais necessários
   carac1 = "'!@#$%¨&*()ºª"
   
    For X = 1 To Len(carac1)
        carac2 = Mid(carac1, X, 1)
        nCampo = Replace(nCampo, carac2, "")
    Next X
 
  fncRemCaracSpc = nCampo

End Function

Function fncRemoveAcentos(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
   '-- Função Trim remove espaços no inicio e fim da string
    fncRemoveAcentos = Trim(texto)
End Function



Se precisar de ajuda para utilizá-las, é só postar aqui.

É isso

[]'s

Bom dia Alexandre

Então, nesse banco não tenho nenhum módulo e também não tenho nenhum formulário
Somente tabelas e a tabela onde preciso executar essa função é na tabela Fisico no campo Descricao.
Troquei o ncampo por descricao mas não estou conseguindo executar a função

Desde já agraço

Bom dia Carlão,

Por gentileza, envie uma cópia do seu banco de dados com poucos registros (20...ou 30) para eu fazer um teste.
Sem as tabelas e o nome das colunas fica mais difícil de te ajudar.

Valeu

[]'s

FIM

Alexandre

Segue conforme sua solicitação


Obrigadu

Carlão,

Criei o campo abaixo, que irá receber os dados do campo "Descricao"


Executar na sequencia abaixo:



1 - A consulta atualização "cnsRemoveCaracEspec" irá executar a função "fncRemCaracSpc" e vai gravar os dados no campo "DescricaoAjus"
2 - A consulta atualização "cnsRemoveAcentos" irá executar a função "fncRemoveAcentos" e vai atualizar o campo "DescricaoAjus"

É necessário executar nesta sequencia.

OBS: Criei a consulta "cnsLimpaCampoAjustado" que limpa o campo "DescricaoAjus", para que seja executado os passos acima, caso tenha faltado algum caracter especial na função "fncRemCaracSpc" ou se algum caracter com acento na função "fncRemoveAcentos".
Neste caso, é só inclui o caracter necessário nas respectivas funções e rode a sequencia novamente.

É isso

Segue exemplo.

Espero ter ajudado

Boa sorte

[]'s

FIM

Alexandre

Muito obrigado

Só mais uma dúvida
Entendi o funcionamento, porém algumas descrições tem dois ou mais espaços entre palavras
Tem como resolver isso também?, pois essas funções tiram somente os espaços no começo e fim


Grato

Carlão,

Infelizmente, você vai ter que tratar essas exceções, e acredito que dá pra fazer bastante coisa com consulta atualização.

O problema é que, se vc incluir o caracter "espaço" na variável da função "fncRemCaracSpc", o sistema vai eliminar TODOS os espaços da palavra:



Se forem muitos casos, ai é melhor fazer via código.

[]'s

FIM

Alexandre

Entendido

Muito obrigado pela valiosa ajuda

Abraços

Valeu Carlão !!!
O fórum agradece.

Sucesso!!!

Alexandre

Só para informação

Fiz a alteração que está como comentada abaixo e acho que resolveu o problema de espaços extras entre palavras

Public Function fncRemCaracSpc(ByVal nCampo As Variant) As String
Dim carac1 As String
Dim carac2 As String
Dim x As Integer

If IsNull(nCampo) Or Trim(nCampo) = "" Then
fncRemCaracSpc = ""
Exit Function
End If

'-- Inclua quais os caracteres especiais necessários
carac1 = "'!@#$%¨&*()ºª/:;"

For x = 1 To Len(carac1)
carac2 = Mid(carac1, x, 1)
nCampo = Replace(nCampo, carac2, "")
'nCampo = Replace(nCampo, " ", " ")
'nCampo = Replace(nCampo, " ", " ")
'nCampo = Replace(nCampo, " ", " ")
Next x

fncRemCaracSpc = nCampo

End Function

Muito bem lembrado !!!
Show!!!
Que bom que deu certo!!!

Sucesso !!!

Resolvendo, Carlao2, não esqueça de marcar o tópico como resolvido. Precisamos manter a casa organizada.

Aguardamos sua ação.

Damasceno

Valeu

Tópico mais que resolvido

Obrigado

Bom dia!