En la hoja tengo esta macro hecha por mi, pregunto si se pudiera mejorar

En la hoja tengo esta macro hecha por mi :

Private Sub Worksheet_Change(ByVal Target As Range)

' Estadillo unicaja

' Para quitar el espacio+letras
Range("F5:G19").Replace What:=" EUR", Replacement:="", LookAt:=xlPart, _
SearchOrder:=xlByRows, MatchCase:=False, SearchFormat:=False, _
ReplaceFormat:=False

' Alinear a la izquierda
Range("E6:E19").HorizontalAlignment = xlLeft

' Convertir a Numero
Range("F5:G19").Select
For Each cd In Selection
On Error Resume Next

'si Val devuelve 0 es porque se trata de celdas con texto, no números guardados como texto
If Val(cd) <> 0 Then
cd.Value = cd.Value * 1
End If
Next

' Ingresar filas vacias
Range("B6:G19").Select
Selection.Insert Shift:=xlDown

' Eliminar filas vacias
Range("B20:G40").Cells.SpecialCells(xlCellTypeBlanks).Delete xlUp
' ESTADILLO ING DIRECT

' Para quitar el espacio+letras
Range("L5:M19").Replace What:=" EUR", Replacement:="", LookAt:=xlPart, _
SearchOrder:=xlByRows, MatchCase:=False, SearchFormat:=False, _
ReplaceFormat:=False

' Alinear a la izquierda
Range("K6:K19").HorizontalAlignment = xlLeft

' Convertir a Numero
Range("L5:M19").Select
For Each cd In Selection
On Error Resume Next

'si Val devuelve 0 es porque se trata de celdas con texto, no números guardados como texto
If Val(cd) <> 0 Then
cd.Value = cd.Value * 1
End If
Next

' Ingresar filas vacias
Range("I6:M19").Select
Selection.Insert Shift:=xlDown

' Eliminar filas vacias
Range("I20:M40").Cells.SpecialCells(xlCellTypeBlanks).Delete xlUp

End Sub

La pregunta es si se puede mejorar.

1 Respuesta

Respuesta
1

H o l a:

Una mejora sería, verificar cierto rango de celdas para que se ejecute la macro.

Así como la tienes, cualquier modificación a cualquier celda, la macro se ejecuta, lo más conveniente es que se ejecute la macro si solamente modificaste una celda de un rango definido.

Te anexo un ejemplo, si una celda del rango F5:G19" o del rango "L5:M19" es modificada, entonces que se ejecute la macro.

Modifica los rangos a lo que es conveniente para tu caso.

También agregué esta instrucción:

Application.EnableEvents = False

Eso significa que mientras se esté ejecutando la macro, los eventos se desactivarán. Te lo comento, ya que en tu macro tienes esto:

Range("F5:G19").Replace What:=" EUR", Replacement:=""

Lo que estás haciendo es modificar el contenido de una celda por "", y esto, nuevamente está modificando una celda, y esto está haciendo que la macro se ejecute nuevamente, entrando en un loop; que puede hacer que excel se bloqueé.

La macro actualizada:

Private Sub Worksheet_Change(ByVal Target As Range)
    If Not Intersect(Target, Range("F5:G19, L5:M19")) Is Nothing Then
        ' Estadillo unicaja
        'Desactiva los eventos
        Application.EnableEvents = False
        ' Para quitar el espacio+letras
        Range("F5:G19").Replace What:=" EUR", Replacement:="", LookAt:=xlPart, _
        SearchOrder:=xlByRows, MatchCase:=False, SearchFormat:=False, _
        ReplaceFormat:=False
        ' Alinear a la izquierda
        Range("E6:E19").HorizontalAlignment = xlLeft
        ' Convertir a Numero
        Range("F5:G19").Select
        For Each cd In Selection
            On Error Resume Next
            'si Val devuelve 0 es porque se trata de celdas con texto, no números guardados como texto
            If Val(cd) <> 0 Then
                cd.Value = cd.Value * 1
            End If
        Next
        ' Ingresar filas vacias
        Range("B6:G19").Select
        Selection.Insert Shift:=xlDown
        ' Eliminar filas vacias
        Range("B20:G40").Cells.SpecialCells(xlCellTypeBlanks).Delete xlUp
        ' ESTADILLO ING DIRECT
        ' Para quitar el espacio+letras
        Range("L5:M19").Replace What:=" EUR", Replacement:="", LookAt:=xlPart, _
        SearchOrder:=xlByRows, MatchCase:=False, SearchFormat:=False, _
        ReplaceFormat:=False
        ' Alinear a la izquierda
        Range("K6:K19").HorizontalAlignment = xlLeft
        ' Convertir a Numero
        Range("L5:M19").Select
        For Each cd In Selection
            On Error Resume Next
            'si Val devuelve 0 es porque se trata de celdas con texto, no números guardados como texto
            If Val(cd) <> 0 Then
                cd.Value = cd.Value * 1
            End If
        Next
        ' Ingresar filas vacias
        Range("I6:M19").Select
        Selection.Insert Shift:=xlDown
        ' Eliminar filas vacias
        Range("I20:M40").Cells.SpecialCells(xlCellTypeBlanks).Delete xlUp
        '
        'Activa los eventos
        Application.EnableEvents = True
    End If
End Sub

Private Sub Worksheet_Change(ByVal Target As Range)
    If Not Intersect(Target, Range("F5:G19, L5:M19")) Is Nothing Then
        ' Estadillo unicaja
        'Desactiva los eventos
        Application.EnableEvents = False
        ' Para quitar el espacio+letras
        Range("F5:G19").Replace What:=" EUR", Replacement:="", LookAt:=xlPart, _
        SearchOrder:=xlByRows, MatchCase:=False, SearchFormat:=False, _
        ReplaceFormat:=False
        ' Alinear a la izquierda
        Range("E6:E19").HorizontalAlignment = xlLeft
        ' Convertir a Numero
        Range("F5:G19").Select
        For Each cd In Selection
            On Error Resume Next
            'si Val devuelve 0 es porque se trata de celdas con texto, no números guardados como texto
            If Val(cd) <> 0 Then
                cd.Value = cd.Value * 1
            End If
        Next
        ' Ingresar filas vacias
        Range("B6:G19").Select
        Selection.Insert Shift:=xlDown
        ' Eliminar filas vacias
        Range("B20:G40").Cells.SpecialCells(xlCellTypeBlanks).Delete xlUp
        ' ESTADILLO ING DIRECT
        ' Para quitar el espacio+letras
        Range("L5:M19").Replace What:=" EUR", Replacement:="", LookAt:=xlPart, _
        SearchOrder:=xlByRows, MatchCase:=False, SearchFormat:=False, _
        ReplaceFormat:=False
        ' Alinear a la izquierda
        Range("K6:K19").HorizontalAlignment = xlLeft
        ' Convertir a Numero
        Range("L5:M19").Select
        For Each cd In Selection
            On Error Resume Next
            'si Val devuelve 0 es porque se trata de celdas con texto, no números guardados como texto
            If Val(cd) <> 0 Then
                cd.Value = cd.Value * 1
            End If
        Next
        ' Ingresar filas vacias
        Range("I6:M19").Select
        Selection.Insert Shift:=xlDown
        ' Eliminar filas vacias
        Range("I20:M40").Cells.SpecialCells(xlCellTypeBlanks).Delete xlUp
        '
        'Activa los eventos
        Application.EnableEvents = True
    End If
End Sub

':)
'S aludos. D a n t e   A m o r . R ecuerda valorar la respuesta. G racias
':)

Añade tu respuesta

Haz clic para o

Más respuestas relacionadas