Archivo de la etiqueta: Vba

ELIMINAR FILAS VACÍAS SI TODAS LAS CELDAS DEL RANGO ESTÁN EN BLANCO PARTE II

Publicado el por

Hola a todos!:

Este post es continuación del anterior: ELIMINAR FILAS VACÍAS SI TODAS LAS CELDAS DEL RANGO ESTÁN EN BLANCO , en el que utilizábamos un ciclo “Do Until”  para eliminar filas en blanco cuando toda la fila (o el rango indicado) estuviese vacía.

Un lector me indicó que sería más sencillo de utilizar un For – Next, dado que era una estructura de programación más fácil de comprender en su funcionamiento. Bien, esto usualmente es así y los procedimientos for – next resultan más sencillos de comprender que los loop tipo: Do While o Do Until.

En este caso, creo que aporta información útil para todos nosotros y he decidido publicarlo. He variado la base de datos para que no sea siempre la misma y he utilizado una hoja de varios miles de registros para el ejemplo:

ELIMINAR FILAS VACÍAS SI TODAS LAS CELDAS DEL RANGO ESTÁN EN BLANCO PARTE II

Vamos a usar la siguiente rutina para realizar el ejercicio de eliminar filas en blanco, solo tendréis que añadir varias filas en blanco y ejecutar el código.

Option Explicit
Sub ELIMINAR_FILAS_VACIAS()
'Declaramos variables
Dim mirango As Object
Dim i As Long
With ActiveSheet
'Contamos hasta la última celda con datos
For i = 1 To .Cells(Rows.Count, 1).End(xlUp).Row
'Si la fila está vacía comenzamos el proceso
If .Application.CountA(Range(i & ":" & i)) = 0 Then
'Si el rango está vacío guardamos primera fila vacía
If mirango Is Nothing Then
Set mirango = Rows(i)
Else
'Si no está vacío utilizamos función Unión()
Set mirango = Union(mirango, Rows(i))
End If
End If
Next i
'Eliminamos contenido de mirango
If Not mirango Is Nothing Then mirango.Delete
End With
'cerramos variable
Set mirango = Nothing: Close
End Sub

El resultado será que la macro va a eliminar la fila o filas vacías en el rango indicado.

Y eso es todo, espero que os haya resultado interesante!.

Descarga el archivo de ejemplo pulsando en: ELIMINAR FILAS VACÍAS SI TODAS LAS CELDAS DEL RANGO ESTÁN EN BLANCO_II

¿Te ha resultado de interés?, puedes apoyar a Excel Signum con una pequeña donación.

Donate Button with Credit Cards

¡¡Muchas gracias!!

Mediante la suscripción al blog, la realización comentarios o el uso del formulario de contacto estás dando tu consentimiento expreso al tratamiento de los datos personales proporcionados según lo dispuesto en la ley vigente (LOPD). Tienes más información al respecto en esta página del blog: Política de Privacidad y Cookies

SELECCIONAR ARCHIVOS DE UNA CARPETA Y ENVIARLOS POR OUTLOOK SEGÚN EL NOMBRE DE LA CARPETA

Publicado el por

Hola a todos!:

Parece que este 2019 ya se va apagando poco a poco!. Y en breve estaremos iniciando el 2020. Espero que todo nos vaya muy bien y se cumplan nuestros sueños y proyecto.

Mientras tanto, voy a escribir un post como respuesta a una consulta:

Hola Segu, una duda, necesito hacer estos envios, pero en lugar de tener el nombre de los aduntos, lo que tengo es el nombre de las carpetas. Mi macro debe recorrer esos nombres, ir abriendo cada carpeta y adjuntando para cada persona todos los archivos que contengan esas rutas.

Es decir, para el destinatario “MANUEL” tengo que ir a la carpeta en ruta que se llame Manuel y enviar en un correo todos los archivos contenidos en esa ruta..

No consigo que me adjunte los archivos..

¿Puedes ayudarme? Gracias

Esta consulta viene como referencia a un post inicial en el que programé un procedimiento automático de envío de archivos según los tengamos detallados en nuestra hoja Excel. Este es el post: SELECCIONAR ARCHIVOS DE UNA CARPETA Y ENVIARLOS POR OUTLOOK SEGÚN CATÁLOGO DE INFORMES

En este caso, lo que el lector solicita es que el código recorra todas las carpetas y cuando se encuentra con las que hemos indicado, adjunte en para cada nombre/carpeta todo el contenido de la misma en el correo de outlook.

Vamos a aprovechar la macro del proceso anterior y modificar algunas rutinas para realice lo que necesitamos:

Sub ENVIAR_CORREOS()
'Declaramos variables
Dim sFSO As Object, Directorio As String
Dim dir_Archivo As Variant
'Abrimos ventana de diálogo para seleccionar carpeta
Set dir_Archivo = Application.FileDialog(msoFileDialogFolderPicker)
dir_Archivo.Show
'Si no seleccionamos nada salimos del proceso
If dir_Archivo.SelectedItems.Count = 0 Then
Exit Sub
End If
'Capturamos el directorio
Directorio = dir_Archivo.SelectedItems(1)
'Creamos objeto y ejecutamos función Carpeta
Set sFSO = CreateObject("Scripting.FileSystemObject")
CARPETA sFSO.GetFolder(Directorio)
End Sub

Function CARPETA(ByVal nCarpeta)
'Declaramos variables
Dim olApp As Outlook.Application
Dim olMail As Outlook.MailItem
Dim fin As Long, i As Long, File As Variant
Dim adjunto As String, nFile As String
Dim olMailItem As Variant, Celda As Variant
'Iniciamos función
With Sheets("Hoja1")
fin = Application.CountA(.Range("A:A"))
'recorremos hoja y celda para comprobar si hace
'referencia a varios archivos.
Set olApp = CreateObject("Outlook.Application")
Set olMail = olApp.CreateItem(olMailItem)
'Recorremos todas las carpetas y subcarpetas
For Each subcarpeta In nCarpeta.SubFolders
CARPETA subcarpeta
Next subcarpeta
For i = 2 To fin
'Si la carpeta se llama igual a la que tenemos en la hoja
'Adjuntamos todo su contenido
If .Cells(i, 1) = nCarpeta.Name Then
For Each File In nCarpeta.Files
adjunto = File
nFile = Left(File.Name, InStr(File.Name, ".") - 1)
'Destinatario
olMail.To = .Cells(i, 2)
'Con copia a
olMail.CC = .Cells(i, 3)
'Con copia oculta
olMail.BCC = .Cells(i, 4)
'Asunto
olMail.Subject = .Cells(i, 1)
'Cuerpo de correo
olMail.HTMLBody = "Buenos días:
Les enviamos los archivos solicitados.
Atentamente."
' Adjuntamos archivo y dejamos correo en bandeja de salida
olMail.Attachments.Add (adjunto)
'Para enviar debéis utilizar Send en lugar de Display
'olMail.Send
olMail.Display
Next File
End If
Next i
olMail: Close
olApp: Close
End With
Set olMail = Nothing
Set olApp = Nothing
End Function

A diferencia del post anterior, en este caso vamos a recorrer todas las carpetas y subcarpetas hasta encontrar la que coincida con la hemos especificado en la hoja. En el momento que lo haga adjuntaremos todos los archivos a Outlook.

Por ejemplo, si elijo uno de mis post (donde guardo todos los archivos con los que escribo la entrada, imágenes, excel, etc):

SELECCIONAR ARCHIVOS DE UNA CARPETA Y ENVIARLOS POR OUTLOOK SEGÚN EL NOMBRE DE LA CARPETA

Y esta sería la carpeta:

SELECCIONAR ARCHIVOS DE UNA CARPETA Y ENVIARLOS POR OUTLOOK SEGÚN EL NOMBRE DE LA CARPETA_1

Con un total de 6 archivos que tendríamos que adjuntar. Si ejecutamos la macro y seleccionamos la carpeta en la que se encuentran los datos, generaremos el siguiente email:

SELECCIONAR ARCHIVOS DE UNA CARPETA Y ENVIARLOS POR OUTLOOK SEGÚN EL NOMBRE DE LA CARPETA_2

Como podéis observar, aquí tenemos el correo con todos los adjuntos de la carpeta que hemos indicado.

Y esta ha sido la contestación a la consulta, espero que también a vosotros os sea de utilidad para vuestros procedimientos de envío.

Descarga el archivo de ejemplo pulsando en: SELECCIONAR ARCHIVOS DE UNA CARPETA Y ENVIARLOS POR OUTLOOK SEGÚN EL NOMBRE DE LA CARPETA

¿Te ha resultado de interés?, puedes apoyar a Excel Signum con una pequeña donación.

Donate Button with Credit Cards

¡¡Muchas gracias!!

Mediante la suscripción al blog, la realización comentarios o el uso del formulario de contacto estás dando tu consentimiento expreso al tratamiento de los datos personales proporcionados según lo dispuesto en la ley vigente (LOPD). Tienes más información al respecto en esta página del blog: Política de Privacidad y Cookies

GENERAR ORGANIGRAMA EN SMARTART CON VBA EN EXCEL

Publicado el por

Hace ya algún tiempo escribí un post sobre cómo confeccionar un organigrama en Excel, fue una entrada basada en fórmulas y teniendo como único soporte nuestra hoja Excel, de forma que antes de introducir las funciones, era necesario “dibujar” la estructura utilizando cada celda como parte del organigrama.

Hoy os propongo desarrollar un organigrama utilizando “SmartArt” en Excel (lo encontraréis en la pestaña insertar de la cinta de opciones) y con VBA.

Antes de comenzar me gustaría comentar que existe muy poca bibliografía sobre la programación en SmartArt, el desarrollo que he realizado se basa fundamentalmente en una labor de investigación y muchas pruebas, dado que apenas existen fuentes (en castellano prácticamente nada).

Vamos a utilizar un ejemplo de una empresa ficticia con 4 niveles de jerarquía. Para ello, necesitamos crear en una hoja (DISEÑO) la estructura que utilizaremos a continuación en nuestras macros. La estructura es esta:

GENERAR ORGANIGRAMA CON VBA EN EXCEL CON SMARTART

En la columna A pondremos los nombres de los departamentos (o de lo que consideremos oportuno), esta información es la que aparecerá dentro de cada “cajita” del organigrama. En la columna B el nivel de jerarquía y en la columna C (opcional, dado que solo sirve para organigramas donde existe una segunda caja para el detalle de nombre o puesto). En el ejemplo, tenemos como primer nivel: “Gerencia”(1), como segundo nivel (2), los departamentos marcados en “Azul”, como tercer nivel (3), los departamentos marcados en “Verde” y como cuarto nivel (4) los marcados en “Blanco”.

* El nivel de jerarquía siempre ha de hacer referencia a los niveles del organigrama. Los niveles debe ir en orden consecutivo, es decir 1,2,3  … y no 1, 2, 4 dado que la macro detectará que no existe el 3 y marcará un error.

Una vez que tenemos la estructura bien definida, vamos a utilizar la siguiente macro para generar nuestro primer organigrama, he elegido la forma tradicional “Organigrama con nombres y puestos” tal y como aparece en SmartArt y que en VBA se define como: “NameandTitleOrganizationalChart” (más adelante os indicaré cómo obtener la referencia de los organigramas).

La macro a utilizar es la siguiente, puede que parezca un poco extensa, pero se debe a que he intentado comentar cada una de las líneas del código para mayor comprensión:

Sub ORGANIGRAMA_VERTICAL_NOMBRE()
Dim Diseño As SmartArtLayout
Dim Shape As Excel.Shape
Dim oNodos As SmartArtNodes
Dim i, Fin As Double
With Sheets("ORG_VERTICAL")
.Select
'Limpiamos cualquier tipo de forma en la hoja2
For Each Shape In .Shapes
Shape.Delete
Next
'Creamos el organigrama partiendo siempre de un tipo concreto: /NameandTitleOrganizationalChart
Set Diseño = Application.SmartArtLayouts("urn:microsoft.com/office/officeart/2008/layout/NameandTitleOrganizationalChart")
Set inserta = .Shapes.AddSmartArt(Diseño)
Set oNodos = inserta.SmartArt.AllNodes
Fin = Application.CountA(Sheets(1).Range("A:A"))
' Mientras el numero de nodos sea inferior a las unidades del organigrama
' Seguimos creando nodos
Do While oNodos.Count < Fin
oNodos.Add.Promote
Loop
For i = 1 To Fin
'Si los niveles del organigrama son inferiores a los niveles
'indicados, eliminamos nodos.
Do While oNodos(i).Level < Sheets(1).Range("B" & i).Value
oNodos(i).Demote
Loop
'Para introducir texto y formato de cada unidad/caja/elemento del organigrama
With oNodos(i)
'Texto dentro de cada unidad
.TextFrame2.TextRange.Text = Sheets(1).Range("A" & i)
'Tamaño del texto de cada unidad
.TextFrame2.TextRange.Font.Size = 9
'Color del texto de cada unidad
.TextFrame2.TextRange.Font.Fill.ForeColor.RGB = RGB(139, 0, 0)
'Negrita
.Shapes.Item(1).TextEffect.FontBold = msoTrue
'Color de fondo de cada unidad
.Shapes.Fill.ForeColor.RGB = vbWhite
'Color del borde de cada unidad
.Shapes.Line.BackColor.RGB = vbBlack
End With
'En el tipo de organigrama "NameandTitle" existe una segunda caja para el detalla del nombre
With oNodos(i).Shapes.Item(2)
'Texto del Nombre.
.TextFrame2.TextRange = Sheets(1).Range("C" & i)
'Color del texto
.TextFrame2.TextRange.Font.Fill.ForeColor.RGB = RGB(0, 0, 139)
'Alineado (centrado)
.TextEffect.Alignment = msoTextEffectAlignmentCentered
'Tipo de letra
.TextEffect.FontName = "Calibri"
'Tamaño de letra
.TextEffect.FontSize = 10
End With
Next
'Formateamos de nuevo el organigrama creado y cambiamos a otro estilo (podemos seguir con el mismo)
'en este caso seguimos aplicando la plantilla NameandTitleOrganizationalChart
For Each Shape In .Shapes
Shape.SmartArt.Layout = Application.SmartArtLayouts("urn:microsoft.com/office/officeart/2008/layout/NameandTitleOrganizationalChart")
'Si deseamos un formato de color predeterminado, solo debemos quitar la comilla simple (') de la sentencia que sigue
'y elegir un formato (cambiando el número de referencia)
'---> 'Shape.SmartArt.Color = Application.SmartArtColors(7) '<-- aquí formateamos el color del organigrama a un estilo predefinido
'Situamos el organanigrama según necesidades y tamaño
With .Shapes(1)
.Height = 500 'Alto
.Width = 1800 'Ancho
.Top = 100 'Arriba
.Left = 100 'Izquierda
End With
Next
End With
End Sub

Lo interesante de la macro (entre otras cosas) es que vamos a aprovecharnos de las opciones de SmarArt para que construya nuestro organigrama con todo su potencial.

Siguiendo una cronología dentro de la macro, lo que hacemos primero es crear un organigrama teniendo como plantilla base: Organigrama con nombres y puestos.
Luego creamos los nodos o los eliminamos, según el tamaño de nuestra estructura, a continuación damos formato a cada una de las cajas (texto, color, bordes, etc) y en este caso, también a las segundas cajas con el detalle del nombre.

Después de tener este organigrama creado, lo que haremos, aunque en este caso no sería necesario, dado que se trata del mismo diseño, es cambiar el tipo de diseño según el organigrama o estructura que necesitemos.  Y os preguntaréis el porqué de cambiar el diseño, la respuesta es que este tipo de diseño recoge perfectamente la lógica de nuestra estructura de Excel, mientras que el resto no lo crea con la fidelidad que necesitamos (por ejemplo un organigrama de jerarquía vertical, interpreta de forma diferente la creación de los nodos en relación con la estructura definida en la hoja (DISEÑO), pero sí lo hace correctamente si cambiamos el diseño si ha sido creado con tipo Organigrama con nombres y puestos (también valdría Organigrama Horizontal), pero siempre la primera plantilla debe ser un organigrama.

Por todo ello, para cambiar el tipo de organigrama o forma, debemos modificar la parte del código que está en rojo, insertando la referencia a la estructura elegida.

El resultado sería el siguiente en SmartArt, (una vez que ejecutéis la macro):

ORGANIGRAMA VERTICAL

Siguiendo con los ejemplos vamos a generar un segundo tipo de organigrama, ahora Organigrama Horizontal, para ello, utilizamos la macro anterior pero tendremos que hacer modificaciones:

Sub ORGANIGRAMA_HORIZONTAL()
Dim Diseño As SmartArtLayout
Dim Shape As Excel.Shape
Dim oNodos As SmartArtNodes
Dim i, Fin As Double
With Sheets("ORG_HORIZONTAL")
.Select
'Limpiamos cualquier tipo de forma en la hoja3
For Each Shape In .Shapes
Shape.Delete
Next
'Creamos el organigrama partiendo siempre de un tipo concreto: /NameandTitleOrganizationalChart
Set Diseño = Application.SmartArtLayouts("urn:microsoft.com/office/officeart/2008/layout/NameandTitleOrganizationalChart")
Set inserta = .Shapes.AddSmartArt(Diseño)
Set oNodos = inserta.SmartArt.AllNodes
Fin = Application.CountA(Sheets(1).Range("A:A"))
' Mientras el numero de nodos sea inferior a las unidades del organigrama
' Seguimos creando nodos
Do While oNodos.Count < Fin
oNodos.Add.Promote
Loop
For i = 1 To Fin
'Si los niveles del organigrama son inferiores a los niveles
'indicados, eliminamos nodos.
Do While oNodos(i).Level < Sheets(1).Range("B" & i).Value
oNodos(i).Demote
Loop
'Para introducir texto y formato de cada unidad/caja/elemento del organigrama
With oNodos(i)
'Texto dentro de cada unidad
.TextFrame2.TextRange.Text = Sheets(1).Range("A" & i)
'Tamaño del texto de cada unidad
.TextFrame2.TextRange.Font.Size = 10
'Negrita
.Shapes.Item(1).TextEffect.FontBold = msoTrue
'Color de fondo de cada unidad
End With
Next
'Formateamos de nuevo el organigrama creado y cambiamos a otro estilo (podemos seguir con el mismo)
'en este caso aplicamos "HorizontalOrganization"
For Each Shape In .Shapes
Shape.SmartArt.Layout = Application.SmartArtLayouts("urn:microsoft.com/office/officeart/2009/3/layout/HorizontalOrganizationChart")
Shape.SmartArt.Color = Application.SmartArtColors(5) '<-- aquí formateamos el color del organigrama a un estilo predefinido
'Situamos el organanigrama según necesidades y tamaño
With .Shapes(1)
.Height = 1000 'Alto
.Width = 1300 'Ancho
.Top = 100 'Arriba
.Left = -50 'Izquierda
End With
Next
End With
End Sub

En primer lugar no necesitamos dar formato a las segundas “cajas” (nombres) dado que este diseño nos las tiene. En segundo lugar, y subrayado en rojo, cambiamos el diseño del organigrama a “HorizontalOrganizationChart”. Aprovecho también para utilizar los estilos de color predefinidos (así no necesitamos dar formato de color a las cajas):

Shape.SmartArt.Color = Application.SmartArtColors(5) , (luego os indicaré cómo encontrar la referencia para cada color).

El resultado es este:

ORGANIGRAMA HORIZONTAL

Ahora vamos a generar un segundo tipo de estructura: la jerarquía. Y crearemos una estructura de Jerarquía Vertical y Horizontal, empezamos con la Vertical:

Aquí tenemos la macro:

Sub JERARQUIA_VERTICAL()
Dim Diseño As SmartArtLayout
Dim Shape As Excel.Shape
Dim oNodos As SmartArtNodes
Dim i, Fin As Double
With Sheets("JERARQUIA_VERTICAL")
.Select
'Limpiamos cualquier tipo de forma en la hoja4
For Each Shape In .Shapes
Shape.Delete
Next
'Creamos el organigrama partiendo siempre de un tipo concreto: /NameandTitleOrganizationalChart
Set Diseño = Application.SmartArtLayouts("urn:microsoft.com/office/officeart/2008/layout/NameandTitleOrganizationalChart")
Set inserta = .Shapes.AddSmartArt(Diseño)
Set oNodos = inserta.SmartArt.AllNodes
Fin = Application.CountA(Sheets(1).Range("A:A"))
' Mientras el numero de nodos sea inferior a las unidades del organigrama
' Seguimos creando nodos
Do While oNodos.Count < Fin
oNodos.Add.Promote
Loop
For i = 1 To Fin
'Si los niveles del organigrama son inferiores a los niveles
'indicados, eliminamos nodos.
Do While oNodos(i).Level < Sheets(1).Range("B" & i).Value
oNodos(i).Demote
Loop
'Para introducir texto y formato de cada unidad/caja/elemento del organigrama
With oNodos(i)
'Texto dentro de cada unidad
.TextFrame2.TextRange.Text = Sheets(1).Range("A" & i)
'Tamaño del texto de cada unidad
.TextFrame2.TextRange.Font.Size = 9
End With
Next
'Formateamos de nuevo el organigrama creado y cambiamos a otro estilo (podemos seguir con el mismo)
'en este caso aplicamos "JERARQUÍA VERTICAL"
For Each Shape In .Shapes
Shape.SmartArt.Layout = Application.SmartArtLayouts("urn:microsoft.com/office/officeart/2005/8/layout/hierarchy1")
Shape.SmartArt.Color = Application.SmartArtColors(4) '<-- aquí formateamos el color del organigrama a un estilo predefinido
Shape.SmartArt.QuickStyle = Application.SmartArtQuickStyles(4) '<-- aquí formateamos el estilo del organigrama a un estilo predefinido
'Situamos el organanigrama según necesidades y tamaño
With .Shapes(1)
.Height = 500 'Alto
.Width = 2500 'Ancho
.Top = 100 'Arriba
.Left = 100 'Izquierda
End With
Next
End With
End Sub

Añadimos el nuevo diseño (subrayado en rojo): hierarchy1 (jerarquía vertical), también vamos a elegir una paleta de colores predefinidas:
Shape.SmartArt.Color = Application.SmartArtColors(4)
y como novedad, aplicamos un estilo rápido, que nos ofrece la posibilidad la cinta de opciones:
Shape.SmartArt.QuickStyle = Application.SmartArtQuickStyles(4)

y este es el resultado:

JERARQUIA VERTICAL

Ahora generaremos una estructura de jerarquía horizontal: “hierarchy2” que es idéntica a la anterior pero modificando diseño, estilo y colores:

Sub JERARQUIA_HORIZONTAL()
Dim Diseño As SmartArtLayout
Dim Shape As Excel.Shape
Dim oNodos As SmartArtNodes
Dim i, Fin As Double
With Sheets("JERARQUIA_HORIZONTAL")
.Select
'Limpiamos cualquier tipo de forma en la hoja5
For Each Shape In .Shapes
Shape.Delete
Next
'Creamos el organigrama partiendo siempre de un tipo concreto: /NameandTitleOrganizationalChart
Set Diseño = Application.SmartArtLayouts("urn:microsoft.com/office/officeart/2008/layout/NameandTitleOrganizationalChart")
Set inserta = .Shapes.AddSmartArt(Diseño)
Set oNodos = inserta.SmartArt.AllNodes
Fin = Application.CountA(Sheets(1).Range("A:A"))
' Mientras el numero de nodos sea inferior a las unidades del organigrama
' Seguimos creando nodos
Do While oNodos.Count < Fin
oNodos.Add.Promote
Loop
For i = 1 To Fin
'Si los niveles del organigrama son inferiores a los niveles
'indicados, eliminamos nodos.
Do While oNodos(i).Level < Sheets(1).Range("B" & i).Value
oNodos(i).Demote
Loop
'Para introducir texto y formato de cada unidad/caja/elemento del organigrama
With oNodos(i)
'Texto dentro de cada unidad
.TextFrame2.TextRange.Text = Sheets(1).Range("A" & i)
'Tamaño del texto de cada unidad
.TextFrame2.TextRange.Font.Size = 9
End With
Next
'Formateamos de nuevo el organigrama creado y cambiamos a otro estilo (podemos seguir con el mismo)
'en este caso aplicamos "JERARQUÍA HORIZONTAL"
For Each Shape In .Shapes
Shape.SmartArt.Layout = Application.SmartArtLayouts("urn:microsoft.com/office/officeart/2005/8/layout/hierarchy2")
Shape.SmartArt.Color = Application.SmartArtColors(14) '<-- aquí formateamos el color del organigrama a un estilo predefinido
Shape.SmartArt.QuickStyle = Application.SmartArtQuickStyles(3) '<-- aquí formateamos el estilo del organigrama a un estilo predefinido
'Situamos el organanigrama según necesidades y tamaño
With .Shapes(1)
.Height = 1000 'Alto
.Width = 800 'Ancho
.Top = 100 'Arriba
.Left = -50 'Izquierda
End With
Next
End With
End Sub

Este es el resultado:

JERARQUIA HORIZONTAL

 Y para finalizar, os agrego un organigrama horizontal pero en 3D, con el código similar a los anteriores, donde modificamos estilo (en este caso en 3D) y colores.

Sub ORGANIGRAMA_3D_HORIZONTAL()
Dim Diseño As SmartArtLayout
Dim Shape As Excel.Shape
Dim oNodos As SmartArtNodes
Dim i, Fin As Double
With Sheets("ORG_3DHORIZONTAL")
.Select
'Limpiamos cualquier tipo de forma en la hoja6
For Each Shape In .Shapes
Shape.Delete
Next
'Creamos el organigrama partiendo siempre de un tipo concreto: /NameandTitleOrganizationalChart
Set Diseño = Application.SmartArtLayouts("urn:microsoft.com/office/officeart/2008/layout/NameandTitleOrganizationalChart")
Set inserta = .Shapes.AddSmartArt(Diseño)
Set oNodos = inserta.SmartArt.AllNodes
Fin = Application.CountA(Sheets(1).Range("A:A"))
' Mientras el numero de nodos sea inferior a las unidades del organigrama
' Seguimos creando nodos
Do While oNodos.Count < Fin
oNodos.Add.Promote
Loop
For i = 1 To Fin
'Si los niveles del organigrama son inferiores a los niveles
'indicados, eliminamos nodos.
Do While oNodos(i).Level < Sheets(1).Range("B" & i).Value
oNodos(i).Demote
Loop
'Para introducir texto y formato de cada unidad/caja/elemento del organigrama
With oNodos(i)
'Texto dentro de cada unidad
.TextFrame2.TextRange.Text = Sheets(1).Range("A" & i)
'Tamaño del texto de cada unidad
.TextFrame2.TextRange.Font.Size = 11
'Negrita
.Shapes.Item(1).TextEffect.FontBold = msoTrue
'Color de fondo de cada unidad
End With
Next
'Formateamos de nuevo el organigrama creado y cambiamos a otro estilo (podemos seguir con el mismo)
'en este caso aplicamos "HorizontalOrganization" en 3D
For Each Shape In .Shapes
Shape.SmartArt.Layout = Application.SmartArtLayouts("urn:microsoft.com/office/officeart/2009/3/layout/HorizontalOrganizationChart")
Shape.SmartArt.Color = Application.SmartArtColors(1) '<-- aquí formateamos el color del organigrama a un estilo predefinido
Shape.SmartArt.QuickStyle = Application.SmartArtQuickStyles(11) '<-- aquí formateamos el estilo del organigrama a un estilo predefinido, 3D
'Situamos el organanigrama según necesidades y tamaño
With .Shapes(1)
.Height = 1000 'Alto
.Width = 1500 'Ancho
.Top = 100 'Arriba
.Left = 100 'Izquierda
End With
Next
End With
End Sub

Este sería el resultado:

ORGANIGRAMA 3DHORIZONTAL

Ahora os explico cómo obtener algunas de las referencias con las que hemos trabajado.

El diseño de la estructura o forma: esto lo podéis ver, si utilizáis el grabador de macros e insertáis la forma de SmartArt que busquéis. La referencia siempre entre paréntesis y comienza por “urn:microsoft.com” este es un ejemplo: “urn:microsoft.com/office/officeart/2005/8/layout/hierarchy2”

Los colores y estilos predefinidos:
teniendo en cuenta que la línea de código para elegir color y estilo

Shape.SmartArt.Color = Application.SmartArtColors(14)

Shape.SmartArt.QuickStyle = Application.SmartArtQuickStyles(3)

Color (14) y estilo (3), debemos pulsar encima del organigrama o forma creada y se abrirán dos pestañas nuevas en nuestra cinta de opciones, “Herramientas de SmartArt” y entramos en Diseño. Si queremos elegir un color, por ejemplo el 14, pulsamos en “Cambiar Colores” y dentro del desplegable, vamos contando desde el primero (1) hasta que hayamos elegido en este caso el 14. Y haremos lo mismo con el estilo rápido, que es el desplegable de justo al lado, en este caso el 3.

Estilos y colores

**Las macros funcionan perfectamente en Excel 2010 y 2016, no he probado en 2013 pero deberían funcionar correctamente. En Excel 2007 y anteriores la macro no funcionará.

El límite de creación de “cajas” (nodos) es ilimitado, sin embargo, el dar formato a los estilos de línea o a los estilos de relleno. El motivo es la colección shapes tiene un límite definido de 256. Es decir que si queréis crear una estructura de más de 256 elementos tendrías que modificar la macro y quedaros solo con la parte del código que ingresa el nombre de los departamentos, sin hacer referencia al objeto shape.

Os dejo un archivo con cinco botones vinculados a cinco hojas que al pulsarlos crean el organigrama. El tiempo de ejecución de cada macro variará en función del tamaño de estructura a crear, en estos ejemplos es de una media de 45 segundos.

El post se podría extender mucho más, pero creo que para recoger la idea y de ver cómo funcionan las macros es suficiente. Os invito a probéis a modificar los diseños y tipos de estructuras, estoy seguro que lo disfrutareis.

Por otra parte, es una forma muy profesional de mantener la estructura o el organigrama de una organización, evitando tener que pasar horas y horas frente al PowerPoint confeccionando cajas.

Pues este ha sido el post de la semana, espero (y estoy seguro que sí), que os sea de utilidad 🙂

Descarga el archivo de ejemplo pulsando en: GENERAR ORGANIGRAMA EN SMARTART CON VBA EN EXCEL