Me gustaría simplificar esta macro

Esta es la macro:

Sub BorrarMiaSeleccion()
Call BorrarDesbloqueadas
Call Borrar1
Call finalizar_las_macros_así
End Sub

Y esto depende de :

Sub BorrarDesbloqueadas()
ActiveSheet.Protect Password:="1"
Dim r As Range
For Each r In Selection
If r.Locked = False Then r.ClearContents
Dim img As Shape
On Error Resume Next
For Each img In ActiveSheet.Shapes
If Not Application.Intersect(img.TopLeftCell, Selection) Is Nothing Then
If img.Type = msoPicture Then img.Delete
End If
Next
Next
End Sub
Sub Borrar1()
Call comenzar_las_macros_así
Dim r As Range
'se recorre el rango seleccionado previamente
For Each r In Selection
'si alguna celda está desbloqueada, se cambia color de fondo y fuente blanca
If r.Locked = False Then
'r.Font.Color = NEGRO
r.Font.Color = RGB(0, 0, 0)
'se limpia contenido
r.ClearContents
r.Interior.Color = RGB(255, 255, 255)
End If
Next
End Sub
Sub comenzar_las_macros_así()
ActiveSheet.Unprotect Password:="1"
Application.ScreenUpdating = False ' Apagar el parpadeo de pantalla
Application.Calculation = xlCalculationManual ' Apagar los cálculos automáticos
Application.EnableEvents = False ' Apagar los eventos automáticos
End Sub
Sub finalizar_las_macros_así()
Application.ScreenUpdating = True ' Debemos volver a su estado original El parpadeo de pantalla
Application.Calculation = xlCalculationAutomatic ' Debemos volver a su estado original Los cálculos automáticos
Application.EnableEvents = True ' Debemos volver a su estado original Los eventos automáticos
Application.CutCopyMode = False ' Borrar contenido de portapapeles
Application.ErrorCheckingOptions.BackgroundChecking = True ' Habilitar comprobacion de errores
ActiveSheet.Protect Password:="1"
End Sub

1 Respuesta

Respuesta
2

Entre las 2 primeras de Borrar se repiten instrucciones, por lo que dejé 1 sola.

Y lo de llamar a las 2 de acciones comunes, bien podrías colocar esas instrucciones dentro de la macro, pero mantenelas separadas si las necesitarás en otros procesos.

No tengo ni idea de cómo están ubicadas tus imágenes, quizás debas subir una imagen de tu hoja o enviármela a mi correo, como para ajustar las instrucciones del 2do bucle que ahora está dentro del 1ro.

Con este cambio no necesitas la de las llamadas, solo se llama a Borrar1.

Sub Borrar1()
'ajustada x Elsamatilde
'se desproteje la hoja y otras acciones comunes
Call comenzar_las_macros_así
Dim r As Range
'se recorre el rango seleccionado previamente
For Each r In Selection
'si alguna celda está desbloqueada, se cambia color de fondo y fuente blanca
If r.Locked = False Then
    'color de fuente
    r.Font.Color = RGB(0, 0, 0)
    'se limpia contenido
    r.ClearContents
    'color de trama
    r.Interior.Color = RGB(255, 255, 255)
End If
Dim img As Shape
On Error Resume Next
For Each img In ActiveSheet.Shapes
    If Not Application.Intersect(img.TopLeftCell, Selection) Is Nothing Then
        If img.Type = msoPicture Then img.Delete
    End If
Next
Next
'se protege la hoja y otras acciones comunes
Call finalizar_las_macros_así
End Sub
Sub comenzar_las_macros_así()
ActiveSheet.Unprotect Password:="1"
Application.ScreenUpdating = False ' Apagar el parpadeo de pantalla
Application.Calculation = xlCalculationManual ' Apagar los cálculos automáticos
Application.EnableEvents = False ' Apagar los eventos automáticos
End Sub
Sub finalizar_las_macros_así()
Application.ScreenUpdating = True ' Debemos volver a su estado original El parpadeo de pantalla
Application.Calculation = xlCalculationAutomatic ' Debemos volver a su estado original Los cálculos automáticos
Application.EnableEvents = True ' Debemos volver a su estado original Los eventos automáticos
Application.CutCopyMode = False ' Borrar contenido de portapapeles
Application.ErrorCheckingOptions.BackgroundChecking = True ' Habilitar comprobacion de errores
ActiveSheet.Protect Password:="1"
End Sub

Añade tu respuesta

Haz clic para o

Más respuestas relacionadas