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….
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
I use layers in Visio a lot. Maybe it is because I originally used CAD, and created facilities and cable management layouts linked to data. I know that some of my fellow Visio MVPS don’t use layers very much at all, mainly because they create process diagrams, I guess, but careful use of layers in…
Well the secret is out … Microsoft are looking for beta testers for the initial release of Visio on iPad. Note, that this is view only, but it should offer a more faithful graphical representation than any third-party product. Plus, it has layer control!Microsoft asks Insiders to comment in particular on the following iPad-specific features: (more…)
Sometimes I get really frustrated with Microsoft. They have a really great data-diagramming product with Visio, which they bought for the largest amount that they had ever paid for an acquisition at the time in 1999, but they have not succeeded in marketing the virtues of visual data to most of the Office community. I…