Macro quita caracteres especiales

[Sanet95]

Hola, buen día.

 

Tengo la siguiente macro que me ayuda a quitar caracteres especiales y/o acentos. Pero actualmente solo busca en un rango o en celda especifica. Como necesito que lo haga en 70 celdas especifcas (sin seguir algun rango o logica) lo que hago es copair y pegar lo mismo solo cambiando la celda. pero al momento de correr   no me deja porque el proyectoes muy largo.

 

¿Alguno de uds podría por favor sugerirme alguna otra manera?

Quedo pendiente y nuevamente muchas gracias

Dejo el código:

 

Sub Quita_acentos()
 

 
'(ByVal SaveAsUI As Boolean, Cancel As Boolean)
'   Auto run when user hits save or closes Excel.  Spanish special characters are
'   replaced in the Description column (P).  Works for capital letters too.

Range("Titulo").Select

'*************************************************************************Quita Acentos******************************************************************************************+

    Selection.Replace What:="á", Replacement:="a", LookAt:=xlPart, _
        SearchOrder:=xlByRows, MatchCase:=False
        
    Selection.Replace What:="ä", Replacement:="a", LookAt:=xlPart, _
        SearchOrder:=xlByRows, MatchCase:=False
        
    Selection.Replace What:="é", Replacement:="e", LookAt:=xlPart, _
        SearchOrder:=xlByRows, MatchCase:=False
        
    Selection.Replace What:="ë", Replacement:="e", LookAt:=xlPart, _
        SearchOrder:=xlByRows, MatchCase:=False
        
    Selection.Replace What:="í", Replacement:="i", LookAt:=xlPart, _
        SearchOrder:=xlByRows, MatchCase:=False
        
    Selection.Replace What:="ï", Replacement:="i", LookAt:=xlPart, _
        SearchOrder:=xlByRows, MatchCase:=False
        
    Selection.Replace What:="ó", Replacement:="o", LookAt:=xlPart, _
        SearchOrder:=xlByRows, MatchCase:=False
        
    Selection.Replace What:="ö", Replacement:="o", LookAt:=xlPart, _
        SearchOrder:=xlByRows, MatchCase:=False
        
    Selection.Replace What:="ú", Replacement:="u", LookAt:=xlPart, _
        SearchOrder:=xlByRows, MatchCase:=False
        
    Selection.Replace What:="ü", Replacement:="u", LookAt:=xlPart, _
        SearchOrder:=xlByRows, MatchCase:=False
        
    Selection.Replace What:="ñ", Replacement:="n", LookAt:=xlPart, _
        SearchOrder:=xlByRows, MatchCase:=False
        
'*************************************************************************Quita Carácteres especiales***********************************************************************
        
         Selection.Replace What:=",", Replacement:=" ", LookAt:=xlPart, _
        SearchOrder:=xlByRows, MatchCase:=False

         Selection.Replace What:="@", Replacement:="", LookAt:=xlPart, _
       SearchOrder:=xlByRows, MatchCase:=False

        Selection.Replace What:="&", Replacement:="", LookAt:=xlPart, _
       SearchOrder:=xlByRows, MatchCase:=False

        Selection.Replace What:="=", Replacement:="", LookAt:=xlPart, _
       SearchOrder:=xlByRows, MatchCase:=False

        Selection.Replace What:="\", Replacement:="", LookAt:=xlPart, _
        SearchOrder:=xlByRows, MatchCase:=False

         Selection.Replace What:="/", Replacement:="", LookAt:=xlPart, _
        SearchOrder:=xlByRows, MatchCase:=False

         Selection.Replace What:=":", Replacement:="", LookAt:=xlPart, _
        SearchOrder:=xlByRows, MatchCase:=False

         Selection.Replace What:="-", Replacement:="", LookAt:=xlPart, _
        SearchOrder:=xlByRows, MatchCase:=False

         Selection.Replace What:="%", Replacement:="", LookAt:=xlPart, _
        SearchOrder:=xlByRows, MatchCase:=False

         Selection.Replace What:="+", Replacement:="", LookAt:=xlPart, _
        SearchOrder:=xlByRows, MatchCase:=False

         Selection.Replace What:="=", Replacement:="", LookAt:=xlPart, _
        SearchOrder:=xlByRows, MatchCase:=False

         Selection.Replace What:="^", Replacement:="", LookAt:=xlPart, _
        SearchOrder:=xlByRows, MatchCase:=False

         Selection.Replace What:="$", Replacement:="", LookAt:=xlPart, _
        SearchOrder:=xlByRows, MatchCase:=False

         Selection.Replace What:="!", Replacement:="", LookAt:=xlPart, _
        SearchOrder:=xlByRows, MatchCase:=False

         Selection.Replace What:=",", Replacement:="", LookAt:=xlPart, _
        SearchOrder:=xlByRows, MatchCase:=False

         Selection.Replace What:="¨", Replacement:="", LookAt:=xlPart, _
        SearchOrder:=xlByRows, MatchCase:=False

          Selection.Replace What:="|", Replacement:="", LookAt:=xlPart, _
        SearchOrder:=xlByRows, MatchCase:=False

         Selection.Replace What:=">", Replacement:="", LookAt:=xlPart, _
        SearchOrder:=xlByRows, MatchCase:=False

         Selection.Replace What:="<", Replacement:="", LookAt:=xlPart, _
        SearchOrder:=xlByRows, MatchCase:=False

         Selection.Replace What:="®", Replacement:="", LookAt:=xlPart, _
        SearchOrder:=xlByRows, MatchCase:=False

         Selection.Replace What:="#", Replacement:="", LookAt:=xlPart, _
        SearchOrder:=xlByRows, MatchCase:=False

         Selection.Replace What:="(", Replacement:="", LookAt:=xlPart, _
        SearchOrder:=xlByRows, MatchCase:=False

         Selection.Replace What:="`", Replacement:="", LookAt:=xlPart, _
        SearchOrder:=xlByRows, MatchCase:=False

         Selection.Replace What:="_", Replacement:="", LookAt:=xlPart, _
        SearchOrder:=xlByRows, MatchCase:=False

         Selection.Replace What:="©", Replacement:="", LookAt:=xlPart, _
        SearchOrder:=xlByRows, MatchCase:=False

         Selection.Replace What:="~", Replacement:="", LookAt:=xlPart, _
        SearchOrder:=xlByRows, MatchCase:=False

         Selection.Replace What:=")", Replacement:="", LookAt:=xlPart, _
        SearchOrder:=xlByRows, MatchCase:=False

         Selection.Replace What:=";", Replacement:="", LookAt:=xlPart, _
        SearchOrder:=xlByRows, MatchCase:=False

        Cells(1, 1).Select
        
        
        
        
End Sub

[Antoni]

Adapta el rango a tus necesidades:

Sub SustituirCaracteres()
cadena1 = "àaèeìiòoúuäaëeïiöoüuñn"
cadena2 = ",@&=\/:-%+=^$!¨|><®#(`_©~);"
'----------------------------------------------------------
Set rango = Range("A1,C7,D10:E14,F1:H1") 'Rango a sustituir '<----------
'----------------------------------------------------------
For Each celda In rango
   For x = 1 To Len(celda)
      i = InStr(cadena1, Mid(celda, x, 1))
      If i Mod 2 = 1 Then
         celda.Value = Replace(celda.Value, Mid(cadena1, i, 1), Mid(cadena1, i + 1, 1))
      End If
   Next
   For x = 1 To Len(celda)
      i = InStr(cadena2, Mid(celda, x, 1))
      If i > 0 Then
         celda.Value = Replace(celda.Value, Mid(cadena2, i, 1), "")
      End If
   Next
Next
End Sub

 

[Sanet95]

Muchas gracias

Mucho más fácil 

[Sanet95]

Duda, ya copie el código pero solo me quita el primer caracter especial, si la celda trae mas de 2 tengo que correr la macro n veces hasta que ya no haya. ¿hay manera de que la misma macro quite todos?

[Antoni]

Corregido y un poco más eficiente:

Sub SustituirCaracteres()
Dim Valor As String, Celda As Range, Cadena As String
Application.ScreenUpdating = False

'Colocar un punto como caracter de sustitución si el caracter a sustiuir se ha de eliminar
Cadena = "àaèeìiòoúuäaëeïiöoüuñn,.@.&.=.\./.:.-.%.+.=.^.$.!.¨.|.>.<.®.#.(.`._.©.~.)."

'----------------------------------------------------------
Set rango = Range("A1,C7,D10:E14,F1:H1") 'Rango a sustituir '<----------
'----------------------------------------------------------

For Each Celda In rango
   Valor = Celda.Text
   For x = 1 To Len(Valor)
      i = InStr(Cadena, Mid(Valor, x, 1))
      If i Mod 2 = 1 Then
         If Mid(Cadena, i + 1) = "." Then
            Valor = Replace(Valor, Mid(Cadena, i, 1), "")
            i = i - 1
         Else
            Valor = Replace(Valor, Mid(Cadena, i, 1), Mid(Cadena, i + 1, 1))
         End If
      End If
   Next
   Celda.Value = Valor
Next
End Sub