Iniciar sesiónCerrar
Correo:
Contraseña:
Entrar
Recordar sesión en este navegador
Iniciar sesiónIniciar sesiónCrear cuentaCrear cuenta
LWP » Foros » Excel » AÑADIR FUNCIONES A LA MACRO EXISTENTE

Excel - AÑADIR FUNCIONES A LA MACRO EXISTENTE

Volver
Nuevo Tema
<<>>
 
Vista:
sin imagen de perfil
Val: 179
Ha aumentado su posición en 2 puestos en Excel (en relación al último mes)
Gráfica de Excel

AÑADIR FUNCIONES A LA MACRO EXISTENTE

Publicado por Jose (80 intervenciones) el 14/08/2018 16:33:10
Bunas tardes,

He deasrollado una plantilla con vuestra ayuda que me va de maravilla.

Ahora necesito para finalizar 2 pequeños detalles y ponerla en practica:

1 - Resaltar las celdas activas (a reelenar en color amarillo).

2 - En el rango de celdas (C5:H5)( escribir solo en mayusculas)

He visto algunas cosas que he intentado de añadirlos a la macro ya existente, pero no consigo adaptarla a mi plantilla.

Esto es lo que he encontrado y preparado para la plantilla que tengo:.

RESALTAR LAS CELDAS EN COLOR AMARILLO

1
2
3
4
Private Sub Worksheet_SelectionChange(ByVal Target As Range)
ActiveSheet.Cells.Interior.ColorIndex = none
Target.Interior.ColorIndex = 6
End Sub

ESCRIBIR EN MAYUSCULAS EN EL RANGO DE CELDAS ESPECIFICADAS

1
2
3
4
5
6
7
8
9
Sub Change()
Private Sub Worksheet_Change(ByVal Target As Range)
On Error Resume Next
Application.EnableEvents = False
If Not Intersect(Range("C5:H5"), Target(1, 1)) Is Nothing Then
   Target(1, 1).Value = UCase(Target)
End If
Application.EnableEvents = True
End Sub

¿Me podeis ayudar? Por favor.

Adjunto el archivo.

Muchas gracias,

Jose
Valora esta pregunta
Me gusta: Está pregunta es útil y esta claraNo me gusta: Está pregunta no esta clara o no es útil
0
Responder
Imágen de perfil de Antoni Masana
Val: 4.908
Oro
Ha mantenido su posición en Excel (en relación al último mes)
Gráfica de Excel

AÑADIR FUNCIONES A LA MACRO EXISTENTE

Publicado por Antoni Masana (2600 intervenciones) el 16/08/2018 07:23:50
Prueba esto:

1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
Option Explicit
 
Private Celda_Ant As String
 
Private Sub Worksheet_SelectionChange(ByVal Target As Range)
    If Len(Celda_Ant) > 0 Then
       Range(Celda_Ant).Cells.Interior.ColorIndex = 0
       Range(Celda_Ant).Interior.ColorIndex = 0
    End If
 
    Target.Cells.Interior.ColorIndex = 0
    Target.Interior.ColorIndex = 6
    Celda_Ant = Target.Address
End Sub
 
Private Sub Worksheet_Change(ByVal Target As Range)
    On Error Resume Next
    Application.EnableEvents = False
    If Not Intersect(Range("C5:H5"), Target(1, 1)) Is Nothing Then
       Target(1, 1).Value = UCase(Target)
    End If
    Application.EnableEvents = True
End Sub

No puedo descargar tu fichero, y no se si es un problema mio o tuyo, esta tarde lo volveré a intentar.

Saludos.
\\//_
Valora esta respuesta
Me gusta: Está respuesta es útil y esta claraNo me gusta: Está respuesta no esta clara o no es útil
0
Comentar
sin imagen de perfil
Val: 179
Ha aumentado su posición en 2 puestos en Excel (en relación al último mes)
Gráfica de Excel

AÑADIR FUNCIONES A LA MACRO EXISTENTE

Publicado por Jose (80 intervenciones) el 16/08/2018 16:12:05
Hola Antoni,
Gracias, ire probando y te dire como me ha ido.
Te adjunto de nuevo el documento.
Saludos,
Jose
Valora esta respuesta
Me gusta: Está respuesta es útil y esta claraNo me gusta: Está respuesta no esta clara o no es útil
0
Comentar
sin imagen de perfil
Val: 179
Ha aumentado su posición en 2 puestos en Excel (en relación al último mes)
Gráfica de Excel

AÑADIR FUNCIONES A LA MACRO EXISTENTE

Publicado por Jose (80 intervenciones) el 16/08/2018 20:52:29
Hola Antoni,
He probado y he conseguido que lo de escribir en mayusculas o minusculas, lo he conseguido.
Adjunto lo logrado.
1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
Private Sub Worksheet_Change(ByVal Target As Range)
    Application.ScreenUpdating = False
    If Target.Address = "$B$14" Or Target.Address = "$C$14" Then
 
       ActiveSheet.Unprotect "Piolino"
 
       If Range("B14") = Empty Or Range("C14") = Empty Then
          Rows("23:30").Select: Selection.EntireRow.Hidden = True
       Else
 
          Rows("23:30").Select: Selection.EntireRow.Hidden = True
          If Range("C14") > 0 And Range("C14") < 9 Then
             Rows("23:" & Range("C14") + 22).Select
             Selection.EntireRow.Hidden = False
          End If
       End If
       Range(Target.Address).Select
 
       ActiveSheet.Protect "Piolino", _
                           DrawingObjects:=False, _
                           Contents:=True, _
                           Scenarios:=True
    End If
    Application.ScreenUpdating = True
    On Error Resume Next
Application.EnableEvents = False
If Not Intersect(Range("C5:H5"), Target(1, 1)) Is Nothing Then
   Target(1, 1).Value = UCase(Target)
End If
On Error Resume Next
Application.EnableEvents = False
If Not Intersect(Range("C6:H6"), Target(1, 1)) Is Nothing Then
   Target(1, 1).Value = LCase(Target)
End If
Application.EnableEvents = True
End Sub
Private Sub SelectUnlockedCells()
    Dim WorkRng As Range
    Dim OutRng As Range
    Dim Rng As Range
    On Error Resume Next
    Set WorkRng = Application.ActiveSheet.UsedRange
    Application.ScreenUpdating = False
        For Each Rng In WorkRng
        If Rng.Locked = False Then
        If OutRng.Count = "" Then
            Set OutRng = Rng
        Else
            Set OutRng = Union(OutRng, Rng)
        End If
Application.ScreenUpdating = True
End Sub



Lo de la RESALTAR las celdas, se me resiste.
Ire probando hasta que me abres los ojos o la suerte me sonrie y me deja sufrir menos.

Saludos,
Gracias.
Valora esta respuesta
Me gusta: Está respuesta es útil y esta claraNo me gusta: Está respuesta no esta clara o no es útil
0
Comentar
Imágen de perfil de Antoni Masana
Val: 4.908
Oro
Ha mantenido su posición en Excel (en relación al último mes)
Gráfica de Excel

AÑADIR FUNCIONES A LA MACRO EXISTENTE

Publicado por Antoni Masana (2600 intervenciones) el 16/08/2018 23:13:41
Lo de resaltar la celda a mi me ha funcionado.

El código es este:

1
2
3
4
5
6
7
8
9
10
11
12
Private Celda_Ant As String
 
Private Sub Worksheet_SelectionChange(ByVal Target As Range)
    If Len(Celda_Ant) > 0 Then
       Range(Celda_Ant).Cells.Interior.ColorIndex = 0
       Range(Celda_Ant).Interior.ColorIndex = 0
    End If
 
    Target.Cells.Interior.ColorIndex = 0
    Target.Interior.ColorIndex = 6
    Celda_Ant = Target.Address
End Sub

Saludos.
\\//_
Valora esta respuesta
Me gusta: Está respuesta es útil y esta claraNo me gusta: Está respuesta no esta clara o no es útil
0
Comentar
sin imagen de perfil
Val: 179
Ha aumentado su posición en 2 puestos en Excel (en relación al último mes)
Gráfica de Excel

AÑADIR FUNCIONES A LA MACRO EXISTENTE

Publicado por Jose (80 intervenciones) el 17/08/2018 09:26:24
Buenos días Antoni,
He colocado la funcion que me has dado en la Hoja1 y me quedo asi:

1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
59
60
61
62
63
64
65
66
Private Celda_Ant As String
 
    Private Sub Worksheet_SelectionChange(ByVal Target As Range)
 
    If Len(Celda_Ant) > 0 Then
       Range(Celda_Ant).Cells.Interior.ColorIndex = 0
 
       Range(Celda_Ant).Interior.ColorIndex = 0
    End If
 
    Target.Cells.Interior.ColorIndex = 0
    Target.Interior.ColorIndex = 6
    Celda_Ant = Target.Address
 
End Sub
  Private Sub Worksheet_Change(ByVal Target As Range)
    Application.ScreenUpdating = False
    If Target.Address = "$B$14" Or Target.Address = "$C$14" Then
 
       ActiveSheet.Cells.Interior.ColorIndex = none
       Target.Interior.ColorIndex = 6
 
       ActiveSheet.Unprotect "aaa"
 
       If Range("B14") = Empty Or Range("C14") = Empty Then
          Rows("23:30").Select: Selection.EntireRow.Hidden = True
       Else
 
          Rows("23:30").Select: Selection.EntireRow.Hidden = True
          If Range("C14") > 0 And Range("C14") < 9 Then
             Rows("23:" & Range("C14") + 22).Select
             Selection.EntireRow.Hidden = False
          End If
       End If
       Range(Target.Address).Select
 
       ActiveSheet.Protect "aaa", _
                           DrawingObjects:=False, _
                           Contents:=True, _
                           Scenarios:=True
    End If
    Application.ScreenUpdating = True
    On Error Resume Next
Application.EnableEvents = False
If Not Intersect(Range("C5:H5"), Target(1, 1)) Is Nothing Then
   Target(1, 1).Value = UCase(Target)
End If
Application.EnableEvents = True
 
End Sub
Private Sub SelectUnlockedCells()
    Dim WorkRng As Range
    Dim OutRng As Range
    Dim Rng As Range
    On Error Resume Next
    Set WorkRng = Application.ActiveSheet.UsedRange
    Application.ScreenUpdating = False
        For Each Rng In WorkRng
        If Rng.Locked = False Then
        If OutRng.Count = "" Then
            Set OutRng = Rng
        Else
            Set OutRng = Union(OutRng, Rng)
        End If
Application.ScreenUpdating = True
End Sub


Pues me da un error en esta linea
Target.Cells.Interior.ColorIndex = 0


Gracias,
Jose
Valora esta respuesta
Me gusta: Está respuesta es útil y esta claraNo me gusta: Está respuesta no esta clara o no es útil
0
Comentar
Imágen de perfil de Antoni Masana
Val: 4.908
Oro
Ha mantenido su posición en Excel (en relación al último mes)
Gráfica de Excel

AÑADIR FUNCIONES A LA MACRO EXISTENTE

Publicado por Antoni Masana (2600 intervenciones) el 17/08/2018 11:12:08
Esto es lo que no estas haciendo, la hoja está protegida.

1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
Private Sub Worksheet_SelectionChange(ByVal Target As Range)
    ActiveSheet.Unprotect "aaa"
 
    If Len(Celda_Ant) > 0 Then
       Range(Celda_Ant).Cells.Interior.ColorIndex = 0
       Range(Celda_Ant).Interior.ColorIndex = 0
    End If
 
    Target.Cells.Interior.ColorIndex = 0
    Target.Interior.ColorIndex = 6
    Celda_Ant = Target.Address
 
    ActiveSheet.Protect "aaa", _
                DrawingObjects:=False, _
                Contents:=True, _
                Scenarios:=True
End Sub


El procedimiento SelectUnlockedCells esta mal.

1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
Private Sub SelectUnlockedCells()
    Dim WorkRng As Range, OutRng As Range, Rng As Range
 
    On Error Resume Next
 
    Set WorkRng = Application.ActiveSheet.UsedRange
 
    Application.ScreenUpdating = False
 
    For Each Rng In WorkRng
        If Rng.Locked = False Then
           If OutRng.Count = "" Then
              Set OutRng = Rng
           Else
              Set OutRng = Union(OutRng, Rng)
           End If
 
    ' --- Aquí falta código, de entrada un END IF y un NEXT

 
    Application.ScreenUpdating = True
End Sub

Saludos.
\\//_
Valora esta respuesta
Me gusta: Está respuesta es útil y esta claraNo me gusta: Está respuesta no esta clara o no es útil
0
Comentar
sin imagen de perfil
Val: 179
Ha aumentado su posición en 2 puestos en Excel (en relación al último mes)
Gráfica de Excel

AÑADIR FUNCIONES A LA MACRO EXISTENTE

Publicado por Jose (80 intervenciones) el 17/08/2018 12:54:19
Gracias,
Debo de ser muy torpe más que seguro.
He conseguido que las celdas NO BLOQUEADAS se clorean en amarilllo, pero al reellenarlas el amarillo se queda y no se quita.
Lo que quiero es despues de escribir en las celdas desprotegidas que se quite el color.
Adjunto de nuevo la plantilla.
Gracias
Valora esta respuesta
Me gusta: Está respuesta es útil y esta claraNo me gusta: Está respuesta no esta clara o no es útil
0
Comentar
Imágen de perfil de Antoni Masana
Val: 4.908
Oro
Ha mantenido su posición en Excel (en relación al último mes)
Gráfica de Excel

AÑADIR FUNCIONES A LA MACRO EXISTENTE

Publicado por Antoni Masana (2600 intervenciones) el 17/08/2018 13:31:00
No eres torpe solo que no lo has visto. Falta la primera linea que debe ir al Inicio del todo el código:

1
Private Celda_Ant As String

Y el procedimiento SelectUnlockedCells esta mal. Falta código, de entrada un END IF y un NEXT.

Saludos.
\\//_
Valora esta respuesta
Me gusta: Está respuesta es útil y esta claraNo me gusta: Está respuesta no esta clara o no es útil
0
Comentar
sin imagen de perfil
Val: 179
Ha aumentado su posición en 2 puestos en Excel (en relación al último mes)
Gráfica de Excel

AÑADIR FUNCIONES A LA MACRO EXISTENTE

Publicado por Jose (80 intervenciones) el 18/08/2018 13:09:45
Hola Antoni,

Lo he probado y va muy bien.
He visto que ahora hay un problema añadido.
Las filas ocultas que tenia que mostrarse segun los datos introducidos en las celdas "B14" y "C14" me da un error '1004' explicando que: "no se puede asignar la propriedad HIDDEN de la clase RANGE".

Adjunto de nuevo el documento.
Gracias y que tengas un buen fin de semana.
Saludos,
Jose
Valora esta respuesta
Me gusta: Está respuesta es útil y esta claraNo me gusta: Está respuesta no esta clara o no es útil
0
Comentar
Imágen de perfil de Antoni Masana
Val: 4.908
Oro
Ha mantenido su posición en Excel (en relación al último mes)
Gráfica de Excel

AÑADIR FUNCIONES A LA MACRO EXISTENTE

Publicado por Antoni Masana (2600 intervenciones) el 20/08/2018 07:17:29
Es el problema de las hoja protegidas, hay que des protegerlas actuar y volver a protegerlas.

1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
59
60
61
62
63
64
65
66
67
68
69
70
71
72
73
74
Private Celda_Ant As String
 
Private Sub Worksheet_SelectionChange(ByVal Target As Range)
    Call Proteger_NO
 
    If Len(Celda_Ant) > 0 Then
       Range(Celda_Ant).Cells.Interior.ColorIndex = 0
       Range(Celda_Ant).Interior.ColorIndex = 0
    End If
 
    Target.Cells.Interior.ColorIndex = 0
    Target.Interior.ColorIndex = 6
    Celda_Ant = Target.Address
 
    Call Proteger_SI
End Sub
 
Private Sub Worksheet_Change(ByVal Target As Range)
    Call Proteger_NO
 
    Application.ScreenUpdating = False
    If Target.Address = "$B$14" Or Target.Address = "$C$14" Then
        ActiveSheet.Cells.Interior.ColorIndex = none
        Target.Interior.ColorIndex = 6
 
        If Range("B14") = Empty Or Range("C14") = Empty Then
 '----      Rows("23:30").Select: Selection.EntireRow.Hidden = True

        Else
 '----      Rows("23:30").Select: Selection.EntireRow.Hidden = True

            If Range("C14") > 0 And Range("C14") < 9 Then
                Rows("23:" & Range("C14") + 22).Select
                Selection.EntireRow.Hidden = False
            End If
        End If
        Range(Target.Address).Select
    End If
    Application.ScreenUpdating = True
    On Error Resume Next
    Application.EnableEvents = False
 
    If Not Intersect(Range("C5:H5"), Target(1, 1)) Is Nothing Then
        Target(1, 1).Value = UCase(Target)
    End If
    Application.EnableEvents = True
    Call Proteger_SI
End Sub
 
Private Sub SelectUnlockedCells()
    Dim WorkRng As Range, OutRng As Range, Rng As Range
    On Error Resume Next
    Set WorkRng = Application.ActiveSheet.UsedRange
    Application.ScreenUpdating = False
    For Each Rng In WorkRng
        If Rng.Locked = False Then
           If OutRng.Count = "" Then
              Set OutRng = Rng
           Else
              Set OutRng = Union(OutRng, Rng)
           End If
        End If
    Next
    Application.ScreenUpdating = True
End Sub
 
Private Sub Proteger_NO()
    ActiveSheet.Unprotect "aaa"
End Sub
 
Private Sub Proteger_SI()
    ActiveSheet.Protect "aaa", _
                DrawingObjects:=False, _
                Contents:=True, _
                Scenarios:=True
End Sub


Saludos.
\\//_
Valora esta respuesta
Me gusta: Está respuesta es útil y esta claraNo me gusta: Está respuesta no esta clara o no es útil
1
Comentar
sin imagen de perfil
Val: 179
Ha aumentado su posición en 2 puestos en Excel (en relación al último mes)
Gráfica de Excel

AÑADIR FUNCIONES A LA MACRO EXISTENTE

Publicado por Jose (80 intervenciones) el 20/08/2018 12:31:12
Buenos dias,
Espero que ha pasado un buen fin de semana.
He hecho la prueba y no me desbloquea las filas.
No se si he entendido bien la explicacion antes de enviarme los cambios.
¿Para que me funcione todo debo de crear una nueva macro nombrandola "Proteger" que hara su trabajo con la funcion CALL?


Saludos,
Jose
Valora esta respuesta
Me gusta: Está respuesta es útil y esta claraNo me gusta: Está respuesta no esta clara o no es útil
0
Comentar
Imágen de perfil de Antoni Masana
Val: 4.908
Oro
Ha mantenido su posición en Excel (en relación al último mes)
Gráfica de Excel

AÑADIR FUNCIONES A LA MACRO EXISTENTE

Publicado por Antoni Masana (2600 intervenciones) el 20/08/2018 13:17:47
He realizado algunos cambios.

Añado esto para que al abrir el libro sepa que celda es la activa

1
2
3
Private Sub Worksheet_Calculate()
    If Len(Celda_Ant) = 0 Then Celda_Ant = ActiveCell.Address
End Sub

De este código hay que quitar tres líneas, las tres comentadas:

1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
Private Sub Worksheet_Change(ByVal Target As Range)
    Call Proteger_NO
    Application.ScreenUpdating = False
    If Target.Address = "$B$14" Or Target.Address = "$C$14" Then
        ActiveSheet.Cells.Interior.ColorIndex = none
        Target.Interior.ColorIndex = 6
        If Range("B14") = Empty Or Range("C14") = Empty Then
                '--- Rows("23:30").Select: Selection.EntireRow.Hidden = True

        Else
                ' --- Rows("23:30").Select: Selection.EntireRow.Hidden = True

            If Range("C14") > 0 And Range("C14") < 9 Then
                Rows("23:" & Range("C14") + 22).Select
                ' --- Selection.EntireRow.Hidden = True

            End If
        End If
        Range(Target.Address).Select
    End If
    Application.ScreenUpdating = True
    On Error Resume Next
    Application.EnableEvents = False
    If Not Intersect(Range("C5:H5"), Target(1, 1)) Is Nothing Then
        Target(1, 1).Value = UCase(Target)
    End If
    Application.EnableEvents = True
    Call Proteger_SI
End Sub


Cuando algo se repite y es susceptible de cambio es mejor hacerlo una vez y seguro que no te equivocas.

El proteger y desproteger las hoja lo tienes que hacer cada vez que haces una modificación. Aquí solo hay dos procesos y lo puedes hacer como antes, es decir así:

1
2
3
4
5
6
7
8
9
10
11
Private Sub Worksheet_SelectionChange(ByVal Target As Range)
    ActiveSheet.Unprotect "aaa"
    ...
    ActiveSheet.Protect "aaa", Drawing...
End Sub
 
Private Sub Worksheet_Change(ByVal Target As Range)
    ActiveSheet.Unprotect "aaa"
    ...
    ActiveSheet.Protect "aaa", Drawing...
End Sub

O de esta forma.

1
2
3
4
5
6
7
8
9
10
11
Private Sub Worksheet_SelectionChange(ByVal Target As Range)
    Call Proteger_NO
    ...
    Call Proteger_SI
End Sub
 
Private Sub Worksheet_Change(ByVal Target As Range)
    Call Proteger_NO
    ...
    Call Proteger_SI
End Sub

De esta última es igual cuantas veces tengas que desproteger las hoja, para cambiar la clave solo necesitar modificar dos líneas de código y hay poca o nula posibilidad de error.

No se si me he explicado bien que sentido tiene estas dos funciones:

1
2
3
4
5
6
7
Private Sub Proteger_NO()
    ActiveSheet.Unprotect "aaa"
End Sub
 
Private Sub Proteger_SI()
    ActiveSheet.Protect "aaa", DrawingObjects:=False, Contents:=True, Scenarios:=True
End Sub

Saludos.
\\//_
Valora esta respuesta
Me gusta: Está respuesta es útil y esta claraNo me gusta: Está respuesta no esta clara o no es útil
0
Comentar
sin imagen de perfil
Val: 179
Ha aumentado su posición en 2 puestos en Excel (en relación al último mes)
Gráfica de Excel

AÑADIR FUNCIONES A LA MACRO EXISTENTE

Publicado por Jose (80 intervenciones) el 21/08/2018 11:10:21
Buenos dias Antoni,
Te explico:
1. La hoja que te envio es la original y es la que va bien, cumpliendo los siguientes requisitos:
- crear un PDF que se adjunta al correo
- abre el correo junto con el PDF creado, que estara listo para enviar al cliente despues de su revision.
- como veras la plantilla (hoja) tiene bloquedas todas las celdas, excepto las celdas activas. Por esto al desplazarse con la tecla enter dentro de la hoja, el desplazamiento sera unicamente entre las celdas activas (celdas que requiere rellenar algunos datos).
- hasta ahora con tu ayuda esta arreglado el tema de las mayusculas o minusculas a corregir de forma automatica en el rango de celdas "C5:H5" y "C6:H6".
- dentro de la plantilla, hay unas filas escondidad que se muestran solo cuando se introduce la fecha de entrada y los dias de estancia que se requiere en las celdas "B14" y "C14" .
Tal como esta ahora la plantilla, funciona muy bien.
2. Falta por lograr de RESALTAR las celdas activas en un color (amarillo en este caso) para que sea más visual y que avise que es una celda o campo a rellenar obligatoriamente, sin que afecte a los demas requisitos especifidaos ateriormente.
Adjunto la plantilla original.
Espero haberme explicado bien esta vez y que tu ayuda sea más facil de entender y aplicar.
Gracias,
Jose
Valora esta respuesta
Me gusta: Está respuesta es útil y esta claraNo me gusta: Está respuesta no esta clara o no es útil
0
Comentar
Imágen de perfil de Antoni Masana
Val: 4.908
Oro
Ha mantenido su posición en Excel (en relación al último mes)
Gráfica de Excel

AÑADIR FUNCIONES A LA MACRO EXISTENTE

Publicado por Antoni Masana (2600 intervenciones) el 21/08/2018 11:57:44
Te envío el fichero corregido.

Y sigo insistiendo, hay un ERROR GRAVE en

1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
' </> --------------------------------------------------------------------- </>

' </> ----&---  ESTA RUTINA TIENE UN ERROR GRAVE                    ---&--- </>

' </> --------------------------------------------------------------------- </>

 
Private Sub SelectUnlockedCells()
    Dim WorkRng As Range
    Dim OutRng As Range
    Dim Rng As Range
 
    On Error Resume Next
 
    Set WorkRng = Application.ActiveSheet.UsedRange
 
    Application.ScreenUpdating = False
 
    For Each Rng In WorkRng                     ' --- ERROR GRAVE

        If Rng.Locked = False Then              ' --- ERROR GRAVE

            If OutRng.Count = "" Then           ' --- ERROR GRAVE

               Set OutRng = Rng                 ' --- ERROR GRAVE

            Else                                ' --- ERROR GRAVE

               Set OutRng = Union(OutRng, Rng)  ' --- ERROR GRAVE

            End If                              ' --- ERROR GRAVE

                                                ' --- ERROR GRAVE

    Application.ScreenUpdating = True
End Sub

Saludos.
\\//_
Valora esta respuesta
Me gusta: Está respuesta es útil y esta claraNo me gusta: Está respuesta no esta clara o no es útil
0
Comentar