Problemas con macro, haber pasado del 2003 al 2007

Al seleccionar las celdas en rojo y ejecutar la macro "Borrar Celdas Selección" me da error en :

Sub BorrarMiaSeleccion()
Application.ScreenUpdating = False ' Apagar el parpadeo de pantalla
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
Call comenzar_las_macros_así
For Each r In Selection
'si alguna celda está desbloqueada, se cambia color de fondo y fuente blanca
If r.Locked = False Then
r.Interior.Color = RGB(255, 255, 255) 'Convierte a color blanco CELDAS SELECIONASA.
r.Font.Color = RGB(0, 0, 0) ' Convierte en Negritas la fuente (texto) de la celda activa.
End If
Next
Call finalizar_las_macros_así
End Sub

En la hoja tengo este código :

Private Sub Worksheet_Change(ByVal Target As Range)
'Por.Dante Amor
'*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-
' AGREGAR FECHA EN UNA COLUMNA
'*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-
If Target.Column = 5 Then
If Cells(Target.Row, "B") = "" Then
ActiveSheet.Unprotect Password:="1"
Cells(Target.Row, "B") = Date
ActiveSheet.Protect Password:="1"
End If
End If
'*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-
' Columnas en MAYUSCULAS
'*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-
If Not Application.Intersect(Target, Range("F7:F2000")) Is Nothing Then
ActiveSheet.Unprotect Password:="1"
Target.Value = UCase(Target)
ActiveSheet.Protect Password:="1"
End If
'*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-
' F O T O S
'*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-
If Not Intersect(Target, Columns("E")) Is Nothing Then
If Target.Count > 1 Then Exit Sub
ActiveSheet.Unprotect Password:="1"
If Target <> "" Then
'*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-
' AGREGAR FOTOS
'*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-
'ruta = "C:\trabajo\Fotos\"
ruta = "G:\Factura\Fotos\"
imagen = Dir(ruta & Target.Value & ".*")
If imagen <> "" Then
imgactual = Cells(Target.Row, "D")
If imgactual <> "" Then
ActiveSheet.Shapes(imgactual).Delete
End If
Set etiqueta = ActiveSheet.Pictures.Insert(ruta & imagen)
With etiqueta
.ShapeRange.LockAspectRatio = msoFalse
.Left = Cells(Target.Row, "D").Left
.Top = Cells(Target.Row, "D").Top
.Height = Range(Cells(Target.Row, "D"), Cells(Target.Row + 4, "D")).Height 'alto imagen
.Width = Cells(Target.Row, "D").Width 'ancho imagen
End With
imgactiva = etiqueta.Name
Cells(Target.Row, "D") = imgactiva
Else
MsgBox "La referencia no tiene foto", vbExclamation
End If
Else
'*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-
' Eliminar FOTOS
'*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-
On Error Resume Next
If Target.Count > 1 Then Exit Sub
imgactual = Cells(Target.Row, "D")
If imgactual <> "" Then
ActiveSheet.Shapes(imgactual).Delete
End If
Cells(Target.Row, "D") = ""
Cells(Target.Row, "B") = ""
End If
ActiveSheet.Protect Password:="1"
End If
End Sub

Y me da error en el código de la hoja en la linea :

If Not Application.Intersect(Target, Range("F7:F2000")) Is Nothing Then

Que esta en el código de la hoja, y en 2003, no me daba.
He puesto el código que me diste :

If Not Intersect(Target, Range("F7:F2000")) Is Nothing Then

Pero sigue igual.

1 respuesta

Respuesta
1

Envíame tu archivo y en una hoja me explicas lo que hacía la macro.

Enviado

La 2ª nota es en la pagina Estadistica venta

No entiendo nada

He cambiado la línea que me diste y no me funcionaba

Pero no se lo que habré hecho, que ahora me funciona de cine

Con 67 años, veo que tengo poca capacidad, mis disculpas por las molestias.

Muchas gracias Dante

Ahora no me funciona

Si no puedes no te preocupes soy un tarado

Un saludo Dante

Deja las 2 líneas en las 2 hojas así:

Private Sub Worksheet_SelectionChange(ByVal Target As Range)
    Calculate            
    Application.ScreenUpdating = True
End Sub

Añade tu respuesta

Haz clic para o

Más respuestas relacionadas