Assigning Visio Shapes to Layers from Excel Table

I work a lot with layers in Visio, and written an add-in, LayerManager, to assist, but I was asked an interesting question recently: How can shapes by assigned to layers automatically from a list in Excel? So, I thought I would present my solution. This particular request was for a Timeline diagram, where the Milestone shapes are to be on specific layers. So, I just used one of the samples provided with Visio.

The first part of solution is to get a list in Excel which can be used to identify the shapes, and to add a column with the desired layer name for each shape, if such a column does not exist already.

Fortunately, the Shape Reports feature in Visio can export a list of shapes to Excel. This tool can export many shape properties and any of the Shape Data that are on the shapes too.

If the report is exported to Excel, it will contain a top row with the title, then the second row contains the column headers, with all of the data below it. Fortunately, Power Query has great abilities, including promoting row values to become the column headers, and transforming text into dates. I decided to add a MonthName column to use as the names of layers in Visio.

So, I now have a table in Excel which has a column with the ID of each shape, and another column that I want to be the name of a layer that the shape needs to be assigned to.

Now I needed a VBA macro to read the active Excel table, and assign the layer to each shape in the active Visio page.

I normally but VBA code in stencils so they can be re-usable with any document. The following code also requires that the Microsoft Excel Object library.

The VBA code is offered below with minimal error trapping:

Option Explicit

Public Sub AssignLayersFromTable()
Dim title As String
title = "AssignLayersFromTable"
On Error GoTo errHandler
Dim excelApp As Excel.Application
Dim sourceWrkbk As Excel.Workbook
Dim sourceWrksht As Excel.Worksheet
Dim sourceTable As Excel.ListObject

Set excelApp = GetExcelApp()
If excelApp Is Nothing Then
    GoTo exitHere
End If
    Set sourceWrkbk = excelApp.ActiveWorkbook
If sourceWrkbk Is Nothing Then
    GoTo exitHere
End If
    Set sourceWrksht = excelApp.ActiveSheet
If sourceWrksht Is Nothing Then
    GoTo exitHere
End If
    Debug.Print sourceWrksht.Name

    If sourceWrksht.ListObjects.Count > 0 Then
        Set sourceTable = sourceWrksht.ListObjects.Item(1)
    End If

Dim listCol As ListColumn
Dim listRow As listRow
Dim msg As String

    If Not sourceTable Is Nothing Then
        Debug.Print sourceTable.Name
        msg = ""
        For Each listCol In sourceTable.ListColumns
            msg = msg & vbCrLf & listCol.Index & vbTab & listCol.Name
            Debug.Print listCol.Index, listCol.Name
            
        Next

Dim retValue As Variant
Dim colShape As Integer
Dim colLayer As Integer

        retValue = InputBox(msg, "Enter the number of the shape ID column")
        If Not IsNumeric(retValue) Then
            MsgBox "Sorry, that was not a number", vbExclamation, title
            GoTo exitHere
        End If
        colShape = CInt(retValue)
        If colShape < 1 Or colShape > sourceTable.ListColumns.Count Then
            MsgBox "Sorry, the number must be in the range", vbExclamation, title
            GoTo exitHere
        End If
        
        retValue = InputBox(msg, "Enter the number of the layer name column")
        If Not IsNumeric(retValue) Then
            MsgBox "Sorry, that was not a number", vbExclamation, title
            GoTo exitHere
        End If
        colLayer = CInt(retValue)
        If colLayer < 1 Or colLayer > sourceTable.ListColumns.Count Then
            MsgBox "Sorry, the number must be in the range", vbExclamation, title
            GoTo exitHere
        End If

Dim shp As Visio.Shape
Dim iLyr As Integer
Dim lyr As Visio.Layer

        For Each listRow In sourceTable.ListRows
            Set shp = ActivePage.Shapes.ItemFromID(listRow.Range(1, colShape))
            If Not LayerExists(ActivePage, listRow.Range(1, colLayer).Value) Then
                ActivePage.Layers.Add listRow.Range(1, colLayer).Value
            End If
            'Remove all assigned layers
            For iLyr = shp.LayerCount To 1 Step -1
                Set lyr = shp.Layer(iLyr)
                lyr.Remove shp, 0
            Next

            Set lyr = ActivePage.Layers(listRow.Range(1, colLayer).Value)
            'Assign to the desired layer
            lyr.Add shp, 0
        Next
        
    End If
    
exitHere:
    Set sourceTable = Nothing
    Set sourceWrksht = Nothing
    Set sourceWrkbk = Nothing
    Set excelApp = Nothing
    
    Exit Sub
errHandler:
    MsgBox Err.Description, vbCritical, "AssignLayersFromTable"
    Resume exitHere
End Sub

Private Function IsOnLayer(ByVal shp As Visio.Shape, ByVal lyrName As String)

End Function


Private Function LayerExists(ByVal pag As Visio.Page, lyrName As String) As Boolean
Dim lyr As Visio.Layer
    For Each lyr In pag.Layers
        If lyr.Name = lyrName Or lyr.NameU = lyrName Then
            LayerExists = True
        End If
    Next
    LayerExists = False
    
End Function


Private Function GetExcelApp() As Excel.Application
On Error Resume Next

Set GetExcelApp = GetObject(, "Excel.Application")

End Function

I hope this helps….

The importance of #layers in Visio for Power BI

Judging by the number of downloads of my free Visio and Power BI GuIde, there is an increasing recognition of this great feature. I recently started to prepare an example for someone, but found that their sample Visio document has just over the 1,000 shape limit, so what can you do about that? The answer…

Layer Set menu options and calls from code added to LayerManager

LayerManager for Microsoft Visio layer sets can now be called from external code and are also available from a sub-menu of the Layer Buttons drop-down ribbon button. The Layer Manager window does not need to be open to use the sub-menu because it detects the Layer Set buttons on the page. (more…)

Update to LayerManager add-in for non-English users

A French user of LayerManager recently reported that the Refresh Counts button was not working for him, and a few other users were recently finding that the trial period was reporting expired immediately after download. Both of these issues have hopefully been addressed in the latest version 23.3.1, which is available for free to current…

Pushing Data Visualizer in Visio to the limits!

Regular readers of my blog will know that I like to use the Data Visualizer (DV) in Visio Plan 2, but I recently tried to help a user who really decided to push it to the limits. In this scenario, there were multiple connections, but with different labels, being created between the same flowchart shapes,…

Editing Visio Layer Colours with LayerManager

Desktop Visio has a tremendous ability to assign shapes to none, one or more layers, and the efficient use of them can make a drawing so powerful by toggling layers visibility or locking certain layers whilst working on other layers. The same drawing can be used, displayed or printed for many different purposes just by…

Fixing the sub-shape layer assignments of Visio shapes

I was preparing a new update of my Layer Manager tool, and was constantly coming across a lack of quality control in the sub-shape layer assignment in a number of the master shapes in Microsoft provided stencils. I have mentioned this to Microsoft as a bug before but the problem still persists in Visio for…