Jump to content

Macro quita caracteres especiales


Recommended Posts

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

Link to comment
Share on other sites

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

 

Link to comment
Share on other sites

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?

Link to comment
Share on other sites

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

 

Edited by Antoni
Link to comment
Share on other sites

  • Crear macros Excel

  • Posts

    • Simplemente pon Tema Solucionado, aunque luego si me da tiempo lo miro
    • Estimados buenos días, En vista de que no sé como eliminar este tema que inicié, les informo que ya pude solucionar el problema, la única solución que pude darle fue realizar las ejecuciones por tiempo, es decir que primero me importe la información que contenga coincidencias entre ambas hojas, me realice los cálculos y luego envíe la información a las hojas correspondientes, luego importa la información que no tienen coincidencia y ahí no realiza ningún cálculo ya que no hay información, entonces esa información la pasa a las hojas respectivas. Lo estuve probando y funciona sin problemas, adjunto el Excel (Macro - Presupuesto) para que puedan revisarlo y si hay alguna otra sugerencia quedaría agradecido para poder ampliar mis conocimientos con respecto a todo este mundo de las Macros, Muchas gracias por su tiempo y disculpen los inconvenientes. Saludos cordiales
    • Muchas gracias a los dos. Ambas respuestas me han servido, pero por sencillez he optado por la de JSDJSD. No obstante, como comenté anteriormente, tengo que tener siempre activa una impresora (de tickets) entonces si le doy a la macro, al crearse el PDF lo hace en el formato de esa impresora. Por tanto, pensé en el inicio de ejecutar la macro poner:  Application.ActivePrinter = "Microsoft Print to PDF" Y una vez finalizada la macro, cambiar a la impresora de Tickets, pero me da error. ¿Hay alguna forma de conseguir esto que comento? Gracias.
    • Ya puedes descargar un Test de Excel, hecho con el cálculo iterativo de las fórmulas de Excel.¡Mentira!¡No lo vas a poder descargar!He incrustado el test en mi blog, y sólo vas a poder realizar el test en modo online, desde un navegador Web o con una tableta o un móvil Android o Mac.   Enlace aquí:https://pedrowave.blogspot.com/2021/10/test-de-excel-con-calculo-iterativo.html     Ventajas de tener el Test de Excel en la nube: No contiene macros VBA ni Office Script. Se actualiza automáticamente al ser un Excel en la Web. Siempre verás la versión más actualizada del Test. Todos los usuarios harán el Test en las mismas condiciones. Se puede hacer el Test en la nube, incluso sin tener Excel instalado. Puedes hacer comentarios al Test en la nube. Puedo actualizar el Test cuando quiera para añadir más preguntas. Puedo modificar su comportamiento, mejorar su uso y/o corregir errores. Puedo proteger mucho mejor mis derechos de autor, para que no se pueda copiar mi idea de este Test de Excel. Gracias anticipadas por seguirme, por tus reacciones y por tus comentarios.
  • Recently Browsing

    • No registered users viewing this page.
×
×
  • Create New...

Important Information

Privacy Policy