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.
1 respuesta
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
- Abre tu libro de Excel
- Para abrir Vba-macros y poder pegar la macro, Presiona Alt + F11
- En el menú elige Insertar / Módulo
- En el panel del lado derecho copia la macro
- Ahora para crear un botón, puedes hacer lo siguiente:
- Inserta una imagen en tu libro, elige del menú Insertar / Imagen / Autoformas
- Elige una imagen y con el Mouse, dentro de tu hoja, presiona click y arrastra el Mouse para hacer grande la imagen.
- 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”
- Vuelve a presionar click derecho dentro de la imagen y ahora selecciona: Asignar macro. Selecciona: Lineas
- Aceptar.
- 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
- Abre tu libro de excel
- Para abrir Vba-macros y poder pegar la macro, Presiona Alt + F11
- Del lado izquierdo dice: VBAProject, abajo dale doble click a worksheet(tu hoja)
- 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
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.
Te lo envío desde gmail y fallo, mi correo es [email protected]
Te lo acabo de mandar por outlook, espro funcione.
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.
- Compartir respuesta