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 i = shp.LayerCount To 1 Step -1 Set lyr = shp.Layer(i) 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….
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…
I have had more than one person ask me how to see the full Layer Manager panel, so I must have not made it clear enough in the help file. Visio has a Developer Mode that is simple to switch on, and provides some extra functionality, including a Developer tab in the ribbon. Layer Manager…
Back in 2012, my fellow Visio MVPs, Scott Helmers and Chris Roth, and I recorded a series of 24 videos about Visio 2010. They were first hosted on Microsoft’s web site, then they put them up on YouTube, they they got deleted :-(. Well, we have managed to retrieve them, and put them back up…
If you are one of the increasing number of Power BI users that have discovered that the Visio Visual gives you the great ability to include Visio diagrams in your dashboard, then you may have come across the following error, ‘We can’t open your file in Visio because it exceeds the shape count limit’ in…
Learn how you can control Visio layer visibility with linked data
Learn how to fix a problem with Visio callouts breaking if layer visibility is toggled