Create Visio Horizontal Swimlane from Excel ActiveSheet

pbornemeier

Well-known Member
Joined
May 24, 2005
Messages
3,910
I was working on another Visio-automation-related question in the forum and a participant asked about adapting it for swimlanes. There are a few rough spots in this code, but it does work. Feedback/suggestions would be appreciated.

Code:
'Create a worksheet with the following characteristics

' A = Process Number    Unique integer to identify each Shape (Phases do not get a process number)
'                         Ascending sequence recommended, not required
' B = Shape Type:       Phase, Process, Decision, Start/End, Document, Data, <blank>
'                         
' C = Offset from Prev  0 Forces block to aligned vertically with previous block
'                       Any number (+/-) offsets the next block from the previous block by that amount
'                       An empty cell uses the default offset (1.5 inches)
' D = Shape Text        Text in the shape (Phase text at top right corner of Phase Block)
'                       Font defaults to 18 point and will be reduced as far as 8 point to 
'                         fit it into the shape
' E = Lane ID		Party Responsible for Task
' F = Connector Text    Text in the connector
' G = Successor Index   Process number for connector destination (Phases do not get a Successor Index)
' H = leave blank          Will be filled with ShapeID

'If you want the lanes to appear in a particular order, populate column D of the 
'  first data rows of the worksheet with the Responsible Party identifiers

'Every shape except Phase and <blank> (and the ending Start/End) must have a Lane ID and a Successor Index


Excel Workbook
ABCDEFG
1ProcessNumberShape TypeOffset from PreviousShape TextLane IDConnector TextSuccessorIndex
2****1st Level Support**
3****Advanced Support**
4****Engineering**
51Start/End*Receive Complaint1st Level Support*2
62Process*Log Complaint1st Level Support*3
73Process*Review problem DB1st Level Support*4
84Decision*Known Problem ?1st Level SupportYes5
9*****No7
105Process*Inform Customer of Fix1st Level Support*6
116Start/End*Close Out Log1st Level Support**
127Process-6Investigate ProblemAdvanced Support*8
138Decision*Workaround Found?Advanced SupportYes9
14*****No11
159Process*Update Problem DBAdvanced Support*10
1610Process*Inform Customer of WorkaroundAdvanced Support*6
1711Process-6Investigate SeverityEngineering*12
1812Decision*Severity ?EngineeringSevere13
19*****Routine14
2013Process*Add Critical Patch RequestEngineering*15
2114Process*Add Change Request for Next ReleaseEngineering*15
2215Process*Update Problem DBEngineering*16
2316Process*Inform Customer of StatusEngineering*6
Sheet3


Code:
Option Explicit
Dim AppVisio As Object

Sub CreateHorizontalSwimLanesFromExcelData()
    'Given a properly constructed worksheet, create a cross-functional flow diagram
    
    Dim aryRange() As Variant '(1,1)...(1,N)   'Process Number,  Shape Type,  Shape Text,  Lane ID, Connector Text,  Successor Index

    Dim aryContents() As Variant    '0...N
    Dim lAryRangeIndex As Long
    Dim bAllInSameVisio As Boolean
    Dim varLaneData() As Variant
    Dim lVarLaneData As Long
    
    Dim lLastDataRow As Long
    Dim sLaneName As String
    Dim varI As Variant
    Dim varK As Variant
    Dim lX As Long
    Dim lLaneCount As Long
    
    Dim lProcNum As Long
    Dim sShapeType As String
    Dim varAlign As Variant
    Dim sShapeText As String
    Dim varLane As Variant
    Dim sConnText As String
    Dim lSuccIndex As Long
    Dim varPreviousLane As Variant
    
    Dim bSkipRow As Boolean
    Dim sngXPos As Single
    Dim sngSameRowDeltaX As Single
    Dim sngDiffRowDeltaX As Single
    Dim sngDeltaX As Single
    Dim bSameRow As Boolean
    
    Dim lFromIndex As Long
    Dim lToIndex As Long
    Dim lFromShape As Long
    Dim lToShape As Long
    Dim lShapeID As Long
    
    Dim sngRightEdgePos As Single
    
    bAllInSameVisio = True
    
    sngXPos = 0.5
    sngSameRowDeltaX = 1.5
    sngDiffRowDeltaX = 1.5
    
    'Load Definition Array from activesheet
    ' A = Process Number    Unique number to identify each Shape (Phases do not get a process number)
    ' B = Shape Type:       <blank>, Phase, Process, Decision, Start/End, Document, Data
    ' C = Offset from Prev  Forces block to aligned vertically with previous block
    ' D = Shape Text        Text in the shape (Phase text at top right corner of Phase Block)
    ' E = Lane ID
    ' F = Connector Text    Text in the connector
    ' G = Successor Index   Process number for connector destination (Phases do not get a Successor Index)
    ' H = <empty>           Will be filled with ShapeID
    
    lLastDataRow = Range("A1").CurrentRegion.Rows.Count
    aryRange = ActiveSheet.Range("A1:H" & lLastDataRow).Value

    'Get Lanes From Loaded Data ('Uniques in column D)
    With CreateObject("Scripting.Dictionary")
        .CompareMode = vbTextCompare
        
        'Inventory column E, row 1 to last populated cell in column E
        For lAryRangeIndex = LBound(aryRange) To UBound(aryRange)
            sLaneName = aryRange(lAryRangeIndex, 5)
            If sLaneName <> vbNullString And sLaneName <> "Lane ID" Then
                .Item(sLaneName) = .Item(sLaneName) + 1
            End If
        Next
        
        'Copy Values (Keys) and Counts (Items) to 1D arrays
        varK = .Keys
        varI = .Items
        
        'Copy both to 2D array
        ReDim varLaneData(1 To 2, 1 To .Count)
        For lX = 1 To .Count
            varLaneData(1, lX) = varK(lX - 1)
            varLaneData(2, lX) = varI(lX - 1)
        Next
    End With
    
    If bAllInSameVisio Then
        'Is Visio already running
        On Error Resume Next
        ' Check whether Visio is running
        Set AppVisio = GetObject(, "Visio.Application")
        If AppVisio Is Nothing Then
            ' Visio is not running, create new instance
            Set AppVisio = CreateObject("visio.Application")
            AppVisio.Visible = True
        End If
    Else
        'Open new copy of Visio
        Set AppVisio = CreateObject("visio.Application")
        AppVisio.Visible = True
    End If
    On Error GoTo 0
    
    'Add New Drawing
    AppVisio.Documents.AddEx "xfunc_u.vst", 0, 0 'visMSDefault, 0
    
    lLaneCount = UBound(varLaneData, 2)
    Select Case lLaneCount
    Case 0
        Stop
        'Error or default to 1 lane ??
    Case 1
        'Delete 1 lane
        ActiveWindow.DeselectAll
        ActiveWindow.Select Application.ActiveWindow.Page.Shapes.ItemFromID(6), 2   '2 = visSelect
        Application.ActiveWindow.Selection.Cut
    Case 2
        'Do nothing, 2 lanes present by default
    Case Else
        For lX = 3 To lLaneCount
            AppVisio.ActivePage.DropIntoList _
                AppVisio.Documents.Item(1).Masters.ItemU("Swimlane"), _
                AppVisio.ActivePage.Shapes.ItemFromID(4), 3
        Next
    End Select
    
    
    varLaneData = ReturnSwimlanesInfo(varK)     '(1,1)...(4,x)  Shape, YPos, Name,  Shape ID
    
    For lAryRangeIndex = LBound(aryRange) + 1 To UBound(aryRange)
        'Update varLane
        For lVarLaneData = LBound(varLaneData, 2) To UBound(varLaneData, 2)
            If aryRange(lAryRangeIndex, 5) = varLaneData(3, lVarLaneData) Then
                 aryRange(lAryRangeIndex, 5) = varLaneData(2, lVarLaneData)
                Exit For
            End If
        Next
    Next
    
    For lAryRangeIndex = LBound(aryRange) + 1 To UBound(aryRange)
        'Evaluate each data row
        
        bSkipRow = False
        
        lProcNum = aryRange(lAryRangeIndex, 1)
        sShapeType = Trim(aryRange(lAryRangeIndex, 2))
        varAlign = aryRange(lAryRangeIndex, 3)
        sShapeText = Trim(aryRange(lAryRangeIndex, 4))
        varLane = aryRange(lAryRangeIndex, 5)
        sConnText = Trim(aryRange(lAryRangeIndex, 6))
        lSuccIndex = aryRange(lAryRangeIndex, 7)
        
        'Debug.Print lAryRangeIndex & "  " & lProcNum & "  " & sShapeType & "  " & _
            varAlign & "  " & sShapeText & "  " & varLane & "  " & sConnText & "  " & lSuccIndex

        If lProcNum = 0 And sShapeType = vbNullString Then bSkipRow = True

        If Not bSkipRow Then
        
            'Calculate New Horizontal Offset
            If sShapeType = "Phase" Or sShapeType = vbNullString Then
                sngDeltaX = 0
            Else
                Select Case varAlign
                Case vbNullString
                    'No entry, use default spacing
                    If varLane = varPreviousLane Then
                        bSameRow = True
                        sngDeltaX = sngSameRowDeltaX
                    Else
                        bSameRow = False
                        sngDeltaX = sngDiffRowDeltaX
                    End If
                Case Is = 0
                    'Align with last plotted shape
                    sngDeltaX = 0
                Case Is > 0, Is < 0
                    'Use entered manual offset
                    sngDeltaX = varAlign
                Case Else
                    'Bad entry, use default spacing
                    If varLane = varPreviousLane Then
                        bSameRow = True
                        sngDeltaX = sngSameRowDeltaX
                    Else
                        bSameRow = False
                        sngDeltaX = sngDiffRowDeltaX
                    End If
                End Select
            End If
            sngXPos = sngXPos + sngDeltaX
            
            
            Select Case sShapeType
            Case "Phase"
                sngRightEdgePos = Replace(AppVisio.ActiveWindow.Page.Shapes.ItemFromID(1).CellsSRC(1, 1, 2).FormulaU, " in", "")
                If sngRightEdgePos < sngXPos + 1.5 Then
                    MsgBox "I have not found a way to programatically adjust the swim lane width." & vbLf & vbLf & _
                        "1) Click OK" & vbLf & _
                        "2) Switch to Visio window" & vbLf & _
                        "3) Adjust the swim lane to as wide as you think you will need" & vbLf & _
                        "4) Return to this screen and press F5", , "Widen Swimlane manually"
                    Stop
                    'SetSwimLaneWidth sngXPos + 1.5 'Would be nice if this worked
                End If
                
                AddPhaseSeparator sngXPos + 0.625, sShapeText
            Case "Process", "Decision", "Subprocess", "Start/End", "Document", "Data"
                aryRange(lAryRangeIndex, 8) = Drop1Shape(lProcNum, sShapeType, sShapeText, sngXPos, CSng(varLane))
                varPreviousLane = varLane
            Case Else
                'Invalid Shape Type - do nothing
            End Select
            
        End If
    Next
    
    SetSwimLaneWidth sngXPos + 1
    
    With CreateObject("Scripting.Dictionary")
        .CompareMode = vbTextCompare
        
        'Inventory aryRange to to get shape number for each process #
        For lAryRangeIndex = LBound(aryRange) To UBound(aryRange)
            If IsNumeric(aryRange(lAryRangeIndex, 1)) And aryRange(lAryRangeIndex, 1) <> 0 Then
                .Item(aryRange(lAryRangeIndex, 1)) = aryRange(lAryRangeIndex, 8)
            End If
        Next
        
        'Copy Values (Keys) and Counts (Items) to 1D arrays
        varK = .Keys
        varI = .Items
        
        'Copy both to 2D array
        ReDim aryProcToShape(1 To 2, 1 To .Count)
        For lX = 1 To .Count
            aryProcToShape(1, lX) = varK(lX - 1)
            aryProcToShape(2, lX) = varI(lX - 1)
        Next
    End With
    

    'Connect Shapes
    For lAryRangeIndex = LBound(aryRange) + 1 To UBound(aryRange)
    
        If aryRange(lAryRangeIndex, 7) <> 0 Then    'Successor Present
            lToIndex = aryRange(lAryRangeIndex, 7)
            If aryRange(lAryRangeIndex, 1) <> 0 Then
                lFromIndex = aryRange(lAryRangeIndex, 1)
            End If
            
            
            For lX = LBound(aryProcToShape, 2) To UBound(aryProcToShape, 2)
                If lFromIndex = aryProcToShape(1, lX) Then lFromShape = aryProcToShape(2, lX)
                If lToIndex = aryProcToShape(1, lX) Then lToShape = aryProcToShape(2, lX)
            Next
            
            'Debug.Print lFromIndex, lToIndex, lFromShape, lToShape
            lShapeID = DoAutoConnect(lFromShape, lToShape, CStr(aryRange(lAryRangeIndex, 6)))
            aryRange(lAryRangeIndex, 8) = lShapeID
        End If
    Next
    
    Set AppVisio = Nothing
    'Set vsoCharacters = Nothing
End Sub

Function ReturnUniquesAndCountsInSelectedRanges(rngInput As Range)
    'Return selected cells' unique values and counts
    
    Dim lX As Long, lY As Long
    Dim rngSelected() As Range  'Array that contains each selected cell
    Dim lSelectedCount As Long
    Dim varA As Variant
    Dim varOutput As Variant
    Dim varK As Variant, varI As Variant
    
    'Iterate all areas; each individual cell into 1D array
    For lX = 1 To rngInput.Areas.Count
        For lY = 1 To rngInput.Areas(lX).Cells.Count
            If Len(rngInput.Areas(lX).Cells(lY).Value) <> 0 Then
                lSelectedCount = lSelectedCount + 1
                ReDim Preserve rngSelected(1 To lSelectedCount)
                Set rngSelected(lSelectedCount) = rngInput.Areas(lX).Cells(lY)
            End If
        Next
    Next
    
    With CreateObject("Scripting.Dictionary")
    
        .CompareMode = vbTextCompare
        
        'Inventory selected cells
        For Each varA In rngSelected
            .Item(varA.Value) = .Item(varA.Value) + 1
        Next
        
        'Copy Values (Keys) and Counts (Items) to 1D arrays
        varK = .Keys
        varI = .Items
        
        'Copy both to 2D array
        ReDim varOutput(1 To 2, 1 To .Count)
        For lX = 1 To .Count
            varOutput(1, lX) = varK(lX - 1)
            varOutput(2, lX) = varI(lX - 1)
        Next
        
    End With
    
    ReturnUniquesAndCountsInSelectedRanges = varOutput

    'Set rngInput = Nothing 'if this is uncommented then the range in the calling routine is set to Nothing as well

End Function

Function Drop1Shape(lProcessNumber As Long, sType As String, sText As String, _
    sngXPos As Single, sngYPos As Single) As Long
    'Adds a shape to the activesheet, returns the ID of the shape
    
    Dim lShapeID As Long

    AppVisio.ActiveWindow.Page.Drop AppVisio.Documents.Item("BASFLO_U.VSS"). _
        Masters.ItemU(sType), sngXPos, sngYPos
    lShapeID = AppVisio.ActiveWindow.Selection.PrimaryItem.ID
    AppVisio.ActiveWindow.Page.Shapes.ItemFromID(lShapeID).CellsSRC(1, 1, 2). _
        FormulaU = "1" 'visSectionObject, visRowXFormOut, visXFormWidth)
    If sType = "Start/End" Then
        AppVisio.ActiveWindow.Page.Shapes.ItemFromID(lShapeID).CellsSRC(1, 1, 3). _
            FormulaU = "0.375" 'visSectionObject, visRowXFormOut, visXFormHeight)
    Else
        AppVisio.ActiveWindow.Page.Shapes.ItemFromID(lShapeID).CellsSRC(1, 1, 3). _
            FormulaU = "0.75" 'visSectionObject, visRowXFormOut, visXFormHeight)
    End If
    
    SetShapeText lShapeID, sText
    Drop1Shape = lShapeID
    
End Function

Sub SetShapeText(lShapeID As Long, sEntry As String)
    'Add Text to Shape, reduce font size from the default size if the text is taller that the shape
    
    Dim vsoCharacters1 As Object
    Dim sShapename As String
    Dim sngTextHeight As Single
    Dim sngFontDefaultSize As Single
    Dim vShapeheight As Variant
    Dim sngFontMinimumSize As Long
    
    sngFontDefaultSize = 18     'Initial size of font in points
    sngFontMinimumSize = 8      'Minimum size of font in points
    
    Set vsoCharacters1 = AppVisio.ActiveWindow.Page.Shapes.ItemFromID(lShapeID).Characters
    vsoCharacters1.Begin = 0
    vsoCharacters1.End = 0
    vsoCharacters1.Text = sEntry
    AppVisio.ActiveWindow.Page.Shapes.ItemFromID(lShapeID).CellsSRC(3, 0, 7).FormulaU = _
        sngFontDefaultSize & " pt"    'visSectionCharacter, 0, visCharacterSize
    
    vShapeheight = AppVisio.ActiveWindow.Page.Shapes.ItemFromID(lShapeID). _
        CellsSRC(1, 1, 3).FormulaU  'visSectionObject, visRowXFormOut, visXFormHeight
    vShapeheight = Replace(vShapeheight, " in", "")
    
    'Debug.Print AppVisio.ActiveWindow.Page.Shapes.ItemFromID(lShapeID).Name
    
    'Reduce vShapeheight for decision shapes
    If InStr(AppVisio.ActiveWindow.Page.Shapes.ItemFromID(lShapeID).Name, "Decision") > 0 Then vShapeheight = vShapeheight / 2
    
    'Add a user-defined cell that contains the height of the textbox
    AppVisio.ActiveWindow.Shape.AddRow 242, 0, 0 'visSectionUser, 0, visTagDefault
    AppVisio.ActiveWindow.Page.Shapes.ItemFromID(lShapeID).CellsSRC(242, 3, 0). _
        RowNameU = "TextHeight" 'visSectionUser, 3, visUserValue
    AppVisio.ActiveWindow.Page.Shapes.ItemFromID(lShapeID).CellsSRC(242, 3, 0). _
        FormulaU = "TEXTHEIGHT(TheText,width)" 'visSectionUser, 3, visUserValue
    
    'If the text box is taller than the shape height, reduce text font size by .5 pt
    '  until it is smaller or font size = 8 pt
    sngTextHeight = AppVisio.ActiveWindow.Page.Shapes.ItemFromID(lShapeID). _
        CellsSRC(242, 3, 0) 'visSectionUser, 3, visUserValue
    Do While sngTextHeight > vShapeheight And sngFontDefaultSize > sngFontMinimumSize
        sngFontDefaultSize = sngFontDefaultSize - 0.5
        sngTextHeight = AppVisio.ActiveWindow.Page.Shapes.ItemFromID(lShapeID). _
            CellsSRC(242, 3, 0)  'visSectionUser, 3, visUserValue
        AppVisio.ActiveWindow.Page.Shapes.ItemFromID(lShapeID).CellsSRC(3, 0, 7). _
            FormulaU = sngFontDefaultSize & " pt"
    Loop
    
    Set vsoCharacters1 = Nothing

End Sub

Public Function ReturnSwimlanesInfo(Optional aryNames As Variant) As Variant
    
    Dim aryContainerIDs() As Long
    Dim iContainer As Integer
    Dim containerShp As Object
    
    Dim varOutput() As Variant, varTemp1 As Variant, varTemp2 As Variant, varTemp3 As Variant, varTemp4 As Variant
    Dim lX As Long, lY As Long
    Dim varOutputIndex As Long
    
    'Set containerShp = CreateObject("Visio.Shape")
    aryContainerIDs = AppVisio.ActivePage.GetContainers(0)  '0= visContainerIncludeNested

    For iContainer = 0 To UBound(aryContainerIDs)
        Set containerShp = AppVisio.ActivePage.Shapes.ItemFromID(aryContainerIDs(iContainer))
        If containerShp.HasCategory("Swimlane") Then
            varOutputIndex = varOutputIndex + 1
            ReDim Preserve varOutput(1 To 4, 1 To varOutputIndex)
            varOutput(1, varOutputIndex) = containerShp.Name
            varOutput(2, varOutputIndex) = containerShp.CellsSRC(1, 1, 1)   'visSectionObject, visRowXFormOut, visXFormPinY
            varOutput(3, varOutputIndex) = containerShp.Text
            varOutput(4, varOutputIndex) = containerShp.ID
            Debug.Print
        End If
    Next
    
    For lY = LBound(varOutput, 2) To UBound(varOutput, 2) - 1
        For lX = lY + 1 To UBound(varOutput, 2)
            If varOutput(2, lY) < varOutput(2, lX) Then
                varTemp1 = varOutput(1, lX)
                varTemp2 = varOutput(2, lX)
                varTemp3 = varOutput(3, lX)
                varTemp4 = varOutput(4, lX)
                varOutput(1, lX) = varOutput(1, lY)
                varOutput(2, lX) = varOutput(2, lY)
                varOutput(3, lX) = varOutput(3, lY)
                varOutput(4, lX) = varOutput(4, lY)
                varOutput(1, lY) = varTemp1
                varOutput(2, lY) = varTemp2
                varOutput(3, lY) = varTemp3
                varOutput(4, lY) = varTemp4
            End If
        Next
    Next
    
    For lX = LBound(aryNames) To UBound(aryNames)
        AppVisio.ActivePage.Shapes.ItemFromID(varOutput(4, lX + 1)).Text = aryNames(lX)
        varOutput(3, lX + 1) = aryNames(lX)
    Next
    
    ReturnSwimlanesInfo = varOutput
    
End Function

Sub AddPhaseSeparator(sngXPos As Single, sTitle As String)
    'Insert a Phase seperator at sngXPos, with the title of sTitle
    
    Dim lShapeID As Long
    
    AppVisio.ActiveWindow.Page.Drop AppVisio.Documents.Item("XFUNC_U.VSS").Masters.ItemU("Separator"), sngXPos, 1
    lShapeID = AppVisio.ActiveWindow.Selection.PrimaryItem.ID
    AppVisio.ActiveWindow.Page.Shapes.ItemFromID(lShapeID).Text = sTitle

End Sub

Sub SetSwimLaneWidth(sngWidth As Single)

    'Enable diagram services
    Dim DiagramServices As Integer
    DiagramServices = AppVisio.ActiveDocument.DiagramServicesEnabled
    AppVisio.ActiveDocument.DiagramServicesEnabled = 7   ' 7 = visServiceVersion140

    AppVisio.ActiveWindow.Page.Shapes.ItemFromID(1).CellsSRC(1, 1, 2).FormulaU = CStr(sngWidth) & " in" 'visSectionObject, visRowXFormOut, visXFormWidth

    'Restore diagram services
    AppVisio.ActiveDocument.DiagramServicesEnabled = DiagramServices


End Sub

Function DoAutoConnect(fromShapeID As Long, toShapeID As Long, sText As String) As Long
    'Modified from: http://visguy.com/vgforum/index.php?topic=6428.0
    'The AutoConnect connector is NOT selected after it is dropped.  This sub
    '  examines all connectors to find the one just created, which allows
    '  that connector to be modified

    Dim conn1 As Object, conn2 As Object
    Dim shpFrom As Object, shpTo As Object
    
    Set shpFrom = AppVisio.ActiveWindow.Page.Shapes.ItemFromID(fromShapeID)
    Set shpTo = AppVisio.ActiveWindow.Page.Shapes.ItemFromID(toShapeID)
    
    'Connect
    shpFrom.AutoConnect shpTo, 0    '0=visAutoConnectDirNone
    
    'Get Connector ID
    For Each conn1 In shpFrom.FromConnects
        For Each conn2 In conn1.FromSheet.Connects
            If conn2.ToSheet.ID = shpTo.ID Then
                DoAutoConnect = conn2.FromSheet.ID
                'Modify Connector
                conn2.FromSheet.Text = sText                'Add sText to connector

            End If
        Next
    Next
    
    Set shpFrom = Nothing
    Set shpTo = Nothing
    Set conn1 = Nothing
    Set conn2 = Nothing
    
End Function
 

Excel Facts

How to find 2nd largest value in a column?
MAX finds the largest value. =LARGE(A:A,2) will find the second largest. =SMALL(A:A,3) will find the third smallest
The short answer is yes. As for details, I can't help right now other than an outline.

Turn on the macro recorder in visio and place then change the color of a connector.
The code to change the color of the connector should be similar to the code in other posts in this thread which should be adaptable to your needs.
I did not distinguish connectors, so just placed the default connector between the shapes I had interest in.
If you ALWAYS have single connector leaving a shape then you can just a connector color to the shape row in the input worksheet.
If there is a chance for multiple connectors, you will have to add a separate entry for each connector and remove the default connector code that I used.
 
Upvote 0
Hi Phil,

Your macro is amazing. I started working on Visio few weeks ago. I tried to use the macro recorder to resolve my issues but I got really confused... I have two questions for you.

1. Is there any possibility to create vertical flowchart?
2. Is there any way to add column (column I) with color name/color code? I'd like to have marked shapes for example on green/blue/red. I tried to use your tips https://www.mrexcel.com/forum/excel...-excel-using-vba-post3542233.html#post3542233 but still couldn't do it.

Thank you
 
Upvote 0
Hello,

Very late to the party but i am having issues adding a Phase - I get the message "Separator cannot be inserted, A separator must be dropped on top of a cross functional flowchart". Anyone else come across this/ found a work around?

Cheers
 
Upvote 0
Hi Phil,

How do we create vertical swimlanes instead of horizontal using the same code.
 
Upvote 0

Forum statistics

Threads
1,213,546
Messages
6,114,255
Members
448,556
Latest member
peterhess2002

We've detected that you are using an adblocker.

We have a great community of people providing Excel help here, but the hosting costs are enormous. You can help keep this site running by allowing ads on MrExcel.com.
Allow Ads at MrExcel

Which adblocker are you using?

Disable AdBlock

Follow these easy steps to disable AdBlock

1)Click on the icon in the browser’s toolbar.
2)Click on the icon in the browser’s toolbar.
2)Click on the "Pause on this site" option.
Go back

Disable AdBlock Plus

Follow these easy steps to disable AdBlock Plus

1)Click on the icon in the browser’s toolbar.
2)Click on the toggle to disable it for "mrexcel.com".
Go back

Disable uBlock Origin

Follow these easy steps to disable uBlock Origin

1)Click on the icon in the browser’s toolbar.
2)Click on the "Power" button.
3)Click on the "Refresh" button.
Go back

Disable uBlock

Follow these easy steps to disable uBlock

1)Click on the icon in the browser’s toolbar.
2)Click on the "Power" button.
3)Click on the "Refresh" button.
Go back
Back
Top