I found this code elsewhere on this Forum and it works fine. It creates a visio shape for each cell in the selected range. The problem is that it creates each new shape on its own NEW Visio drawing page.
How would I modify this macro to create each shape on the SAME Visio drawing. I don't care if they cover each other's position; I just want to have them on the same drawing.
----------------
Sub VisioFromExcel()
Dim AppVisio As Object
Dim oCharacters As Object
Dim lX As Long
Dim sChar As String
Set AppVisio = CreateObject("visio.application")
AppVisio.Visible = True
For lX = 1 To Cells(Rows.Count, 1).End(xlUp).Row
AppVisio.Documents.AddEx "block_u.vst", 0, 0
AppVisio.Windows.ItemEx(lX).Activate
AppVisio.ActiveWindow.Page.Drop AppVisio.Documents.Item("BLOCK_U.VSS").Masters.ItemU("Box"), 1.35, 9.8
AppVisio.ActiveWindow.Page.Shapes.ItemFromID(1).CellsSRC(visSectionCharacter, 0, visCharacterSize).FormulaU = "20 pt"
Set oCharacters = AppVisio.ActiveWindow.Page.Shapes.ItemFromID(1).Characters
oCharacters.Begin = 0
oCharacters.End = Len(oCharacters)
sChar = Cells(lX, 1).Value
oCharacters.Text = sChar
Next
Set oCharacters = Nothing
Set AppVisio = Nothing
End Sub
--------------------
Thanks,
Joe
How would I modify this macro to create each shape on the SAME Visio drawing. I don't care if they cover each other's position; I just want to have them on the same drawing.
----------------
Sub VisioFromExcel()
Dim AppVisio As Object
Dim oCharacters As Object
Dim lX As Long
Dim sChar As String
Set AppVisio = CreateObject("visio.application")
AppVisio.Visible = True
For lX = 1 To Cells(Rows.Count, 1).End(xlUp).Row
AppVisio.Documents.AddEx "block_u.vst", 0, 0
AppVisio.Windows.ItemEx(lX).Activate
AppVisio.ActiveWindow.Page.Drop AppVisio.Documents.Item("BLOCK_U.VSS").Masters.ItemU("Box"), 1.35, 9.8
AppVisio.ActiveWindow.Page.Shapes.ItemFromID(1).CellsSRC(visSectionCharacter, 0, visCharacterSize).FormulaU = "20 pt"
Set oCharacters = AppVisio.ActiveWindow.Page.Shapes.ItemFromID(1).Characters
oCharacters.Begin = 0
oCharacters.End = Len(oCharacters)
sChar = Cells(lX, 1).Value
oCharacters.Text = sChar
Next
Set oCharacters = Nothing
Set AppVisio = Nothing
End Sub
--------------------
Thanks,
Joe