Public Function fncVS_ProcList_NewPropirties() As Boolean
'всем шэйпам Process присваевает свои новые данные
'On Error GoTo Err01:
Dim vsDoc As Visio.Document
Dim vsPage As Visio.Page
Dim vsSp As Visio.Shape
Dim ii%, jj%

Set vsDoc = ThisDocument
Set vsPage = vsDoc.Pages(1)

For Each vsPage In vsDoc.Pages 'листы Visio
Debug.Print vsPage.Name
If vsPage.Shapes.Count > 0 Then
    Set vsSp = vsPage.Shapes(1)
    Else
    GoTo NextPg:
    End If
    
    For Each vsSp In vsPage.Shapes
        If VBA.Left(vsSp.NameU, 7) <> "Process" Then
            GoTo NextSh:
            End If
        Debug.Print vsSp.Name, vsSp.Text '
        With vsSp
            vsSp.DeleteSection visSectionProp
            vsSp.AddSection visSectionProp
            vsSp.AddRow visSectionProp, 0, 0
            'On Error Resume Next
            For jj = 0 To 7 'удаляем созданные по умолчанию для процесса
                vsSp.DeleteRow visSectionProp, 0
            Next jj
            
            For jj = 0 To 3 'создаем нужное число строк свойств
                vsSp.AddRow visSectionProp, 0, 0
            Next jj 'vsSp.AddRow visSectionProp, 0, 0
            
            .CellsSRC(visSectionProp, 0, visCustPropsValue).RowName = "ProcessCode"
            .CellsSRC(visSectionProp, 1, visCustPropsValue).RowName = "ProcessName"
            .CellsSRC(visSectionProp, 2, visCustPropsValue).RowName = "PartCode"
            .CellsSRC(visSectionProp, 3, visCustPropsValue).RowName = "PartName"
                
            .CellsSRC(visSectionProp, 0, visCustPropsValue).Formula = """T000.000"""
            .CellsSRC(visSectionProp, 1, visCustPropsValue).Formula = """Название T000.000"""
            .CellsSRC(visSectionProp, 2, visCustPropsValue).Formula = """00000.0"""
            .CellsSRC(visSectionProp, 3, visCustPropsValue).Formula = """Название подразделения 00000.0"""
            
            'просто просмотрим что получилось
            For jj = 0 To 3
                Debug.Print .CellsSRC(visSectionProp, jj, visCustPropsValue).RowName, .CellsSRC(visSectionProp, jj, visCustPropsValue).Formula
            Next jj
        
        End With
NextSh:    Next 'vsSp
NextPg: Next 'vsPage

Exit Function
Err01:
MsgBox ("Ошибка функции:  fncVS_ProcList_NewPropirties" & vbCrLf & Err.code & " - " & Err.Description)
End Function

.CellsSRC(visSectionProp, 0, visCustPropsValue).Formula 

For ii = 1 To 100
Debug.Print ii, Addons.Item(ii).Name
Next ii

Dim vsDoc As Visio.Document
Dim vsPg As Visio.Page
'øýéïû
Dim vsSh1 As Visio.Shape
Dim vsSh2 As Visio.Shape
Dim vsSh3 As Visio.Shape
Dim vsSh4 As Visio.Shape
'ñîåä.ëèíèÿ
Dim vsShC As Visio.Shape
''''''''''''''''''''''''''''''''''''''''
Set vsDoc = ThisDocument
Set vsPg = vsDoc.Pages(1)

Set vsSh1 = vsPg.Drop(Application.Documents.Item("BASFLO_M.VSS").Masters.ItemU("Process"), 2#, 4#)
Set vsSh2 = vsSh1.Duplicate
Set vsSh3 = vsSh1.Duplicate
Set vsSh4 = vsSh1.Duplicate

With vsSh1
    .Text = "Level1"
    .CellsSRC(visSectionObject, visRowXFormOut, visXFormPinX).FormulaU = VBA.CStr(120) & " mm"
    .CellsSRC(visSectionObject, visRowXFormOut, visXFormPinY).FormulaU = VBA.CStr(150) & " mm"
End With
With vsSh2
    .Text = "Level2.1"
    .CellsSRC(visSectionObject, visRowXFormOut, visXFormPinX).FormulaU = VBA.CStr(80) & " mm"
    .CellsSRC(visSectionObject, visRowXFormOut, visXFormPinY).FormulaU = VBA.CStr(40) & " mm"
End With
With vsSh3
    .Text = "Level2.2"
    .CellsSRC(visSectionObject, visRowXFormOut, visXFormPinX).FormulaU = VBA.CStr(120) & " mm"
    .CellsSRC(visSectionObject, visRowXFormOut, visXFormPinY).FormulaU = VBA.CStr(40) & " mm"
End With
With vsSh4
    .Text = "Level2.3"
    .CellsSRC(visSectionObject, visRowXFormOut, visXFormPinX).FormulaU = VBA.CStr(160) & " mm"
    .CellsSRC(visSectionObject, visRowXFormOut, visXFormPinY).FormulaU = VBA.CStr(40) & " mm"
End With

''''''''''''''''''''''''''''''''''''''''
Set vsShC = vsPg.Drop(Application.ConnectorToolDataObject, 2#, 2#)
vsShC.CellsU("BeginX").GlueTo vsSh1.CellsSRC(7, 2, 0)
vsShC.CellsU("EndX").GlueTo vsSh2.CellsSRC(7, 3, 0)
vsShC.CellsSRC(visSectionObject, visRowShapeLayout, visSLORouteStyle).FormulaU = 16

Set vsShC = vsPg.Drop(Application.ConnectorToolDataObject, 2#, 2#)
vsShC.CellsU("BeginX").GlueTo vsSh1.CellsSRC(7, 2, 0)
vsShC.CellsU("EndX").GlueTo vsSh3.CellsSRC(7, 3, 0)
vsShC.CellsSRC(visSectionObject, visRowShapeLayout, visSLORouteStyle).FormulaU = 16

Set vsShC = vsPg.Drop(Application.ConnectorToolDataObject, 2#, 2#)
vsShC.CellsU("BeginX").GlueTo vsSh1.CellsSRC(7, 2, 0)
vsShC.CellsU("EndX").GlueTo vsSh4.CellsSRC(7, 3, 0)
vsShC.CellsSRC(visSectionObject, visRowShapeLayout, visSLORouteStyle).FormulaU = 16

Public Sub pCreateExtraColumns() 
    Dim vme As New VisioModelingEngine 
    Dim models As IEnumIVMEModels 
    Dim model As IVMEModel 
    Dim erModel As IVMEERModel 
    Dim entities As IEnumIVMEEntities 
    Dim entity As IVMEEntity 
    Dim attrs As IEnumIVMEAttributes 
    Dim attr As IVMEAttribute 
    Dim ivDataType As IVMEDataType 
    Dim intColumnNumberCount As Integer 
    Dim strDataType As String 
    Set models = vme.models 
    Do Until Not (model Is Nothing) 
        Set model = models.Next 
        If Not (model Is Nothing) Then 
            If (model.ModelKind = eVMEModelERLogical) Then 
                Set erModel = model 
                Set entities = erModel.entities 
                Do 
                    Set entity = entities.Next 
                    If Not (entity Is Nothing) Then 
                        Debug.Print entity.PhysicalName 
                        Set attrs = entity.Attributes 
                        intColumnNumberCount = 0 
                        Do 
                            Set attr = attrs.Next 
                            If Not (attr Is Nothing) Then 
                                intColumnNumberCount = 
intColumnNumberCount + 1 
                            End If 
                        Loop Until (attr Is Nothing) 
                        Set attr = entity.CreateAttribute() 
                        Set ivDataType = attr.DataType 
                        attr.ColumnNumber = intColumnNumberCount 
                        attr.PhysicalName = "TestColumnName" 
            '            strDataType = "varchar(100)" 
            '            ivDataType.PhysicalName = strDataType 'this 
line does not work as PhysicalName is readonly 
                        attr.DataType = ivDataType 
                    End If 
                Loop Until (entity Is Nothing) 
            End If 
        End If 
    Loop 
End Sub 

AddRow visSectionProp, jj, visCustPropsValue

.CellsSRC(visSectionProp, jj, visCustPropsValue).RowNameU ="Значение_01"

.CellsSRC(visSectionProp, jj, visCustPropsValue).RowNameU ="Значение_01"

.CellsSRC(visSectionProp, jj, visCustPropsLabel).FormulaU = """my label"""

dim wb as excel.workbook
dim vs as visio.shape
set vs = thisdocument.shapes("excelsheet") 
set wb = vs.object