GENERAR ORGANIGRAMA EN SMARTART CON VBA EN EXCEL II

Hola a todos!

Hace ya varios años que publiqué un post sobre la posibilidad de programar SmartArt con VBA en Excel para crear estructuras y automatizar su diseño.

Hago aquí referencia al post del que estoy hablando: GENERAR ORGANIGRAMA EN SMARTART CON VBA EN EXCEL

El post de hoy es para publicar una mejora en el código que he vuelto a reescribir y mejorar algunas cosas para que sea un poco más rápido.

En el ejemplo solo voy a publicar tres estructuras:

Sub ORGANIGRAMA_NOMBRE_TITULO()

    Dim Diseño As SmartArtLayout
    Dim inserta As Shape
    Dim oNodos As SmartArtNodes
    Dim i As Long, Fin As Long
    Dim HojaOrigen As Worksheet, HojaOrganigrama As Worksheet
    Dim ValorNivel As Long

    ' Referencia a las hojas
    Set HojaOrigen = Sheets(1)
    Set HojaOrganigrama = Sheets("ORG_VERTICAL")

    With Application
        .ScreenUpdating = False
        .Calculation = xlCalculationManual
    End With

    ' Eliminar formas existentes en la hoja
    For Each inserta In HojaOrganigrama.Shapes
        inserta.Delete
    Next

    ' Crear el organigrama
    Set Diseño = Application.SmartArtLayouts("urn:microsoft.com/office/officeart/2008/layout/NameandTitleOrganizationalChart")
    Set inserta = HojaOrganigrama.Shapes.AddSmartArt(Diseño)
    Set oNodos = inserta.SmartArt.AllNodes

    Fin = HojaOrigen.Range("A:A").Cells.SpecialCells(xlCellTypeConstants).Count

    ' Añadir nodos
    Do While oNodos.Count < Fin
        oNodos.Add.Promote
    Loop

    For i = 1 To Fin
        ValorNivel = HojaOrigen.Cells(i, 2).Value
        
        ' Ajustar el nivel de nodo
        Do While oNodos(i).Level < ValorNivel
            oNodos(i).Demote
        Loop

        ' Configurar propiedades del nodo
        With oNodos(i)
            .TextFrame2.TextRange.Text = HojaOrigen.Cells(i, 1).Value
            .TextFrame2.TextRange.Font.Size = 9
            .TextFrame2.TextRange.Font.Fill.ForeColor.RGB = RGB(139, 0, 0)
            .Shapes.Item(1).TextEffect.FontBold = msoTrue
            .Shapes.Fill.ForeColor.RGB = vbWhite
            .Shapes.Line.BackColor.RGB = vbBlack
        End With

        ' Configurar nombre
        With oNodos(i).Shapes.Item(2)
            .TextFrame2.TextRange = HojaOrigen.Cells(i, 3).Value
            .TextFrame2.TextRange.Font.Fill.ForeColor.RGB = RGB(0, 0, 139)
            .TextEffect.Alignment = msoTextEffectAlignmentCentered
            .TextEffect.FontName = "Calibri"
            .TextEffect.FontSize = 10
        End With
    Next i

    ' Establecer dimensiones del organigrama
    With HojaOrganigrama.Shapes(1)
        .Height = 500 'Alto
        .Width = 1800  'Ancho
        .Top = 100    'Arriba
        .Left = 100   'Izquierda
    End With

    ' Reactivar actualizaciones y cálculos
    With Application
        .ScreenUpdating = True
        .Calculation = xlCalculationAutomatic
    End With
    Sheets("ORG_VERTICAL").Activate

End Sub

Este código genera el típico organigrama con departamentos y nombres de responsables. Siguiendo con los datos del post inicial se mostrará esto:

Y ahora sigamos con el siguiente código:

Sub ORGANIGRAMA_HORIZONTAL()

    Dim Diseño As SmartArtLayout
    Dim inserta As Shape
    Dim oNodos As SmartArtNodes
    Dim i As Long, Fin As Long
    Dim HojaOrigen As Worksheet, HojaOrganigrama As Worksheet
    Dim ValorNivel As Long

    ' Referencia a las hojas
    Set HojaOrigen = Sheets(1)
    Set HojaOrganigrama = Sheets("ORG_HORIZONTAL")

    With Application
        .ScreenUpdating = False
        .Calculation = xlCalculationManual
    End With

    ' Eliminar formas existentes en la hoja
    For Each inserta In HojaOrganigrama.Shapes
        inserta.Delete
    Next

    ' Crear el organigrama
    Set Diseño = Application.SmartArtLayouts("urn:microsoft.com/office/officeart/2009/3/layout/HorizontalOrganizationChart")
    Set inserta = HojaOrganigrama.Shapes.AddSmartArt(Diseño)
    Set oNodos = inserta.SmartArt.AllNodes

    Fin = HojaOrigen.Range("A:A").Cells.SpecialCells(xlCellTypeConstants).Count

    ' Añadir nodos
    Do While oNodos.Count < Fin
        oNodos.Add.Promote
    Loop

    For i = 1 To Fin
        ValorNivel = HojaOrigen.Cells(i, 2).Value
        
        ' Ajustar el nivel de nodo
        Do While oNodos(i).Level < ValorNivel
            oNodos(i).Demote
        Loop

        ' Configurar propiedades del nodo
        With oNodos(i)
            .TextFrame2.TextRange.Text = HojaOrigen.Cells(i, 1).Value
            .TextFrame2.TextRange.Font.Size = 9
            .TextFrame2.TextRange.Font.Fill.ForeColor.RGB = RGB(139, 0, 0)
            .Shapes.Item(1).TextEffect.FontBold = msoTrue
            .Shapes.Fill.ForeColor.RGB = vbWhite
            .Shapes.Line.BackColor.RGB = vbBlack
        End With
    Next i

 For Each Shape In Sheets("ORG_HORIZONTAL").Shapes
           
       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
     
  Next


    ' Establecer dimensiones del organigrama
    With HojaOrganigrama.Shapes(1)
        .Height = 1000 'Alto
        .Width = 1300  'Ancho
        .Top = 100    'Arriba
        .Left = -50   'Izquierda
    End With

    ' Reactivar actualizaciones y cálculos
    With Application
        .ScreenUpdating = True
        .Calculation = xlCalculationAutomatic
    End With
    Sheets("ORG_HORIZONTAL").Activate

End Sub

Que va a generar el siguiente código:

Y para finalizar y cambiando ya de estructura, ahora jerarquía:

Y esto es todo, espero que sea de utilidad!!

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



¡¡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