Macro quitar acentos de una hoja
Es un gusto saludarlos nuevamente.
Si es posible, por favor su ayuda con la siguiente macro:
Tengo estos códigos para quitar acentos y /, pero me presenta 2 problemas:
- Esta macro realiza la función para todo el libro y solo necesito que lo realice en la hoja2.
- Al quitar el acento de las minúsculas, funciona, pero convierte la letra en mayúscula.
Por favor su ayuda!
Sub ReplaceAll()
Dim s(13) As String, r(13) As String
Dim cell As Excel.Range
Dim i As Byte
On Error Resume Next
Application.ScreenUpdating = False
s(0) = "Ñ"
s(1) = "Á"
s(2) = "É"
s(3) = "Í"
s(4) = "Ó"
s(5) = "Ú"
s(6) = "ñ"
s(7) = "á"
s(8) = "é"
s(9) = "í"
s(10) = "ó"
s(11) = "ú"
s(12) = "/"
r(0) = "N"
r(1) = "A"
r(2) = "E"
r(3) = "I"
r(4) = "O"
r(5) = "U"
r(6) = "n"
r(7) = "a"
r(8) = "e"
r(9) = "i"
r(10) = "o"
r(11) = "u"
r(12) = ""
For Each cell In ActiveSheet.UsedRange
For i = 0 To 12
With cell
.Value = VBA.Replace(.Value, s(i), r(i), 1, -1, vbTextCompare)
End With
Next
Next
Application.ScreenUpdating = True
End Sub
2 respuestas
El problema lo tienes en cómo está comparando la función Replace.
Cambia vbTextCompare por vbBinaryCompare y te funcionará correctamente, pon:
.Value = VBA.Replace(.Value, s(i), r(i), 1, -1, vbBinaryCompare)
Para que sólo se ejecute en la hoja que quieras, sitúa el código de arriba, que estará en un módulo, en la hoja que quieras.
1º Si pulsas ALT + F11 irás al editor de VBA
2º Mira donde tienes el código de arriba, córtalo
3º Selecciona en el cuadro de la izquierda, la hoja que quieres controlar y haz doble clic en ella.
4º Pega el código en el cuadro de la derecha. Listo.
Si te ha valido la respuesta.
Muchas gracias Marcial por tu respuesta.
Realicé el cambio que me sugeriste, pero no me resulta.
Es muy probable que debe ser porque tengo otras funciones incluidas en la misma macro y esta gira eternamente, agrego la macro completa para que la puedas ver:
Sheets("hoja2").Select
Dim s(12) As String, r(12) As String
Dim cell As Excel.Range
Dim i As Byte
On Error Resume Next
Application.ScreenUpdating = False
s(0) = "Ñ"
s(1) = "Á"
s(2) = "É"
s(3) = "Í"
s(4) = "Ó"
s(5) = "Ú"
s(6) = "ñ"
s(7) = "á"
s(8) = "é"
s(9) = "í"
s(10) = "ó"
s(11) = "ú"
s(12) = "/"
r(0) = "N"
r(1) = "A"
r(2) = "E"
r(3) = "I"
r(4) = "O"
r(5) = "U"
r(6) = "n"
r(7) = "a"
r(8) = "e"
r(9) = "i"
r(10) = "o"
r(11) = "u"
r(12) = ""
For Each cell In ActiveSheet.UsedRange
For i = 0 To 12
With cell
.Value = VBA.Replace(.Value, s(i), r(i), 1, -1, vbBinaryCompare)
End With
Next
Next
Application.ScreenUpdating = True
' CON ESTA INDICACION SE VAN A ELIMINAR LOS ESPACIOS ANTES Y DESPUES DE CADA CELDA
Set rango = Range("A1:J" & Range("A" & Rows.Count).End(xlUp).row)
For Each celda In rango
celda.Value = Trim(celda)
Next
' CON ESTA INDICACION ELIMINA LOS DECIMALES
Range("K2:Q15000").Select
Range("K2:Q15000").NumberFormat = "0"
Range("A2").Select
End Sub
Es probable que no te funcione porque para que lo haga, tal y cómo está la macro, funciona cuando tienes un rango seleccionado.
Si quieres que funcione para un rango determinado, cambia la línea de código:
For Each cell In ActiveSheet.UsedRange
por:
For Each cell In Range("A1:J" & Range("A" & Rows.Count).End(xlUp).row)
Estoy suponiendo que en ese rango están los datos a los que quieres sacar los acentos, si no es así, cambia las letras.
Si te ha valido la respuesta.
