Requiero una macro que me dibule líneas inclinadas

Tengo un arcvico en excel que me genera las constancias de estudios de los alumnos, cuanto cambio la celda A1 (contiene el número de identificación del alumno) todo el archivo coloca las calificaciones y demás datos a la contancias de estudios.

Tengo otra celda LMN3 ( es una celda combinada de l3 a m23, la cual contiene una lista desplegable de los seis semestres que debe cursar cualquier alumno para concluir su bachillerato.)

El MACRO que requiero necesito que al momento de seleccionar el semestres que cursa el alumno, en los siguientes semestres que les falta les coloque una línea recta negra inclinada como en la imagen que les muestro a continuación.

Respuesta
4

H o l a : No entendí esta parte:

"LMN3 ( es una celda combinada de l3 a m23" no sé cuáles son las celdas combinadas.


Pero puedes poner la siguiente macro en un botón. Presionas el botón y la macro te creará las líneas inclinadas.

En tu imagen se aprecia la palabra "CALIF" si abajo de esta palabra las celdas están vacías, significa que hay que poner la línea inclinada.

Pon la siguiente macro en un módulo y asígnala a un botón.

Sub Lineas()
'Por.Dante Amor
    'Borrando líneas anteriores
    For Each s In ActiveSheet.Shapes
        If s.Name = "milineacreada" Then
            s.Delete
        End If
    Next
    '
    Set r = Range("B:B, G:G")
    Set b = r.Find("CALIF", lookat:=xlWhole)
    If Not b Is Nothing Then
        celda = b.Address
        Do
            'Creando líneas
            If Cells(b.Row + 1, b.Column) = "" Then
                Set r1 = Cells(b.Row + 1, b.Column)
                fila = b.Row + 1
                Do While Cells(fila, b.Column - 1) <> ""
                    fila = fila + 1
                Loop
                Set r2 = Cells(fila, b.Column + 2)
                Set linea = ActiveSheet.Shapes.AddLine(r1.Left, r1.Top, r2.Left, r2.Top)
                linea.Name = "milineacreada"
            End If
            Set b = r.FindNext(b)
        Loop While Not b Is Nothing And b.Address <> celda
    End If
End Sub

Sigue las Instrucciones para un botón y ejecutar la macro

  1. Abre tu libro de Excel
  2. Para abrir Vba-macros y poder pegar la macro, Presiona Alt + F11
  3. En el menú elige Insertar / Módulo
  4. En el panel del lado derecho copia la macro
  5. Ahora para crear un botón, puedes hacer lo siguiente:
  6. Inserta una imagen en tu libro, elige del menú Insertar / Imagen / Autoformas
  7. Elige una imagen y con el Mouse, dentro de tu hoja, presiona click y arrastra el Mouse para hacer grande la imagen.
  8. Una vez que insertaste la imagen en tu hoja, dale click derecho dentro de la imagen y selecciona: Tamaño y Propiedades. En la ventana que se abre selecciona la pestaña: Propiedades. Desmarca la opción “Imprimir Objeto”. Presiona “Cerrar”
  9. Vuelve a presionar click derecho dentro de la imagen y ahora selecciona: Asignar macro. Selecciona: Lineas
  10. Aceptar.
  11. Para ejecutarla dale click a la imagen.

Ahora, si quieres que la macro se ejecute en automático y suponiendo que la celda que tiene la lista es la "L3". Pon la siguiente macro en los eventos de tu hoja.

Private Sub Worksheet_Change(ByVal Target As Range)
'Por.Dante Amor
    If Target.Count > 1 Then Exit Sub
    If Not Intersect(Target, Range("L3")) Is Nothing Then
        'Borrando líneas anteriores
        For Each s In ActiveSheet.Shapes
            If s.Name = "milineacreada" Then
                s.Delete
            End If
        Next
        '
        Set r = Range("B:B, G:G")
        Set b = r.Find("CALIF", lookat:=xlWhole)
        If Not b Is Nothing Then
            celda = b.Address
            Do
                'Creando líneas
                If Cells(b.Row + 1, b.Column) = "" Then
                    Set r1 = Cells(b.Row + 1, b.Column)
                    fila = b.Row + 1
                    Do While Cells(fila, b.Column - 1) <> ""
                        fila = fila + 1
                    Loop
                    Set r2 = Cells(fila, b.Column + 2)
                    Set linea = ActiveSheet.Shapes.AddLine(r1.Left, r1.Top, r2.Left, r2.Top)
                    linea.Name = "milineacreada"
                End If
                Set b = r.FindNext(b)
            Loop While Not b Is Nothing And b.Address <> celda
        End If
    End If
End Sub

Sigue las Instrucciones para poner la macro en los eventos de worksheet

  1. Abre tu libro de excel
  2. Para abrir Vba-macros y poder pegar la macro, Presiona Alt + F11
  3. Del lado izquierdo dice: VBAProject, abajo dale doble click a worksheet(tu hoja)
  4. En el panel del lado derecho copia la macro

Nota: La línea quedará ajustada al ancho de las columnas B y D, pero si después de poner la línea, ajustas el ancho de la columna D, la línea no se ajustará, solamente se ajustará si ajustas el ancho de la columna B.


'S aludos. Dante Amor. Recuerda valorar la respuesta. G racias

¡Gracias! voy a intenatr hacer lo que dices  y te comento que pasó, por cierto la lista desplegable que uso se encuentra en una celda combinada que abarca las celdas L3,M3 y N3

Hola ya pegue el macro como me mencionas pero no funcionó,

mira la celda combinada que tengo que ir cambiando es esta

y requiero que al seleccionar tercer semestre los demás semestres aparezcan con la línea de esta forma

Envío otro ejemplo al seleccionar "QUINTO"

Debe aparecer 

debe aparecer 

La celda que tiene la lista desplegable contiene los textos:

PRIMER

SEGUNDO

TERCER

CUARTO

QUINTO

SEXTO

Los rangos en donde requiero que aparezcan las líneas son:

G18:I26

B29:D37

G29:I37

B40:D49

G40:I49

Pusiste la macro en un botón.

Pon la macro en un botón. Llena los semestres, es decir, pon las calificaciones en las celdas y después presiona el botón.

Si tienes problemas para poner el botón, envíame tu archivo para adaptar la macro.+

Mi correo [email protected]

En el asunto del correo escribe tu nombre de usuario “Rafael Concha” y el título de esta pregunta.

¡Gracias! 

Enviado

Saludos

Te lo envío desde gmail y fallo, mi correo es [email protected]

Te lo acabo de mandar por outlook, espro funcione.

Me ha rechazado tu mail, me dicen ambos correos que no existe 

AL parecer tiene problemas el correo de yahoo.

Envíame el archivo a

[email protected]

¡Gracias! 

Lo acabo de enviar al nuevo correo

Gracias

Te anexo la macro actualizada

Private Sub Worksheet_Change(ByVal Target As Range)
'Por.Dante Amor
    If Target.Count > 1 Then Exit Sub
    If Not Intersect(Target, Range("L8")) Is Nothing Then
        'Borrando líneas anteriores
        For Each s In ActiveSheet.Shapes
            If s.Name = "milineacreada" Then
                s.Delete
            End If
        Next
        '
        Set r = Range("B17:D49, G17:I49")
        Set B = r.Find("CALIF", lookat:=xlWhole)
        If Not B Is Nothing Then
            celda = B.Address
            Do
                'Creando líneas
                If Cells(B.Row + 1, B.Column) = "" Then
                    Set r1 = Cells(B.Row + 1, B.Column)
                    fila = B.Row + 1
                    Do While Cells(fila, B.Column).HasFormula
                        fila = fila + 1
                    Loop
                    Set r2 = Cells(fila, B.Column + 3)
                    Set linea = ActiveSheet.Shapes.AddLine(r1.Left, r1.Top, r2.Left, r2.Top)
                    linea.Name = "milineacreada"
                End If
                Set B = r.FindNext(B)
            Loop While Not B Is Nothing And B.Address <> celda
        End If
    End If
End Sub

R e cuerda cambiar la valoración a la respuesta.

Añade tu respuesta

Haz clic para o

Más respuestas relacionadas