Excel to Visio via VBA

Started by wapperdude, September 02, 2016, 06:41:43 PM

Previous topic - Next topic

0 Members and 1 Guest are viewing this topic.

wapperdude

OK, so another User request sent me down the bunny trail...hippity hoppity!   ::)

Sometimes, you just want to search an Excel file, and then paste selectable contents into Visio, without the hassle of using "Reports".  This may be the opportunity you've wanted!

The attached code and sample file do the following:
  1)  From within Visio, go search for an Excel file and open it.  The initial search starts with the root directory containing the Visio file.  But, thru standard navigation methods, any directory may be searched.
  2)  It only looks for Excel files.  After all, that the goal of this in the first place.
  3)  Once open, the sub waits for you to select worksheet cells, range of cells, on a single page.  You may navigate to a desired page, and make selection, but, it only accepts range selections on a single active page...I think.
  4)  Copies content of each cell into a separate Visio shape.  These can be moved about as desired.

Once the range of cells is finished, there are a series of queries: exit sub, select more cells, get a different Excel file, save any changes made to Excel file.

Included as comments at the top of the file is a list of References that need to activated for VBA functionality.

Here's the code:

Sub MyMac()
'
' The macro is now interactive.  Once the initial selection of Excel cells has been copied
' to Visio shapes, macro asks to exit or not.  If not, it will prompt to make a new set of
' cell selections.  If this is not desired from current Excel file, it will prompt for a new
' file.  NOTE, if a new selection in current file is desired, you will have to click on the
' Excel window to regain its focus.
'
' Before exiting the sub, you will be prompted to save changes to existing Excel file.
'
' This macro has updated code to begin "hunt" for Excel file beginning with
' Visio drawing root directory.  Old code is still here, commented out.
' It is still possible to search other directories.
'
' The following references are used:
'   Visual Basic for Applications
'   Microsoft Visio Type Library
'   OLE Automation
'   Microsoft Office Object Library
'   Microsoft Excel Object Library
'   You'll have to choose the appropriate versions based upon your installation
'
    Dim XlApp As Object
    Dim XlWrkbook As Excel.Workbook
    Dim XlSheet As Excel.Worksheet
    Dim rng As Range
    Dim docPath As Variant
   
    Dim vsoCharacters1 As Visio.Characters
    Dim visSel As Visio.Shape
    Dim ptX1 As Double
    Dim ptX2 As Double
    Dim ptY1 As Double
    Dim ptY2 As Double
    Dim dltX As Double
    Dim dltY As Double
   
'Initial shape location
    ptX1 = 3
    ptX2 = 5
    ptY1 = 3
    ptY2 = 3.5
    dltX = 0.25
    dltY = 0.25
   
    docPath = ActiveDocument.Path
    Set XlApp = CreateObject("Excel.Application")
   
SelFile:
    With XlApp.FileDialog(msoFileDialogFilePicker)
        .Filters.Clear
        .Filters.Add "Excel Files", "*.xls, *.xlsx, *.xlsm"
        .InitialFileName = docPath
        .Show
        XlApp.Workbooks.Open FileName:=.SelectedItems(1)
    End With
   
    Set XlWrkbook = XlApp.Workbooks(1)
    Set XlSheet = XlWrkbook.Worksheets("Sheet1")
    XlApp.Visible = True

' Old file hunting routine:
'    Dim fNameAndPath As Variant
'
'    fNameAndPath = XlApp.GetOpenFilename(FileFilter:="Excel Files (*.XLS), *.XLS, (*.XLSX), *.XLSX, (*.XLSM), *.XLSM", Title:="Select File To Be Opened")
'    If fNameAndPath = False Then Exit Sub
'    XlApp.Workbooks.Open FileName:=fNameAndPath
'    Set XlWrkbook = Workbooks.Open(fNameAndPath)
'    Set XlSheet = XlWrkbook.Worksheets("Sheet1")
'    XlApp.Visible = True
   
SelCells:
    Set rng = XlApp.InputBox("Select a range", "Obtain Range Object", Type:=8)


'Transfer Excel contents to Visio shapes on active page
    For Each Cell In rng
        Cell.Copy
               
        Visio.ActiveWindow.Page.DrawRectangle ptX1, ptY1, ptX2, ptY2
        Set visSel = Visio.ActiveWindow.Selection(1)
        Set vsoCharacters1 = visSel.Characters
        vsoCharacters1.Begin = 0
        vsoCharacters1.End = 0
        ActiveWindow.SelectedText = vsoCharacters1
        ActiveWindow.SelectedText.Paste
       
' Options:  remove fill and line patterns-> only text is visible
        visSel.TextStyle = "Normal"
        visSel.LineStyle = "Text Only"
        visSel.FillStyle = "Text Only"
       
        ActiveWindow.DeselectAll
       
' Increment next shape location:
        ptX1 = ptX1 + dltX
        ptX2 = ptX2 + dltX
        ptY1 = ptY1 + dltY
        ptY2 = ptY2 + dltY

    Next
   
' User Prompts:
    If MsgBox("Exit Subroutine?", vbYesNo, "Exit Sub") = vbYes Then
        GoTo EndIt
    End If
    If MsgBox("Make additional selections?", vbYesNo, "Continue Selections") = vbYes Then
        GoTo SelCells
    End If
    If MsgBox("Select new Excel file?", vbYesNo, "Select File") = vbYes Then
        GoTo SelFile
    End If
           
EndIt:
    If MsgBox("Save Excel file changes?", vbYesNo, "Excel Update") = vbYes Then
        XlWrkbook.Close SaveChanges:=True
    Else
        XlWrkbook.Close SaveChanges:=False
    End If
    XlApp.Quit
     
End Sub


Enjoy.
Wapperdude
Visio 2019 Pro

Visisthebest

Wapperdude thank you again for this superuseful code, I have used it many times to get data from Excel in to Visio to generate a complete diagram from Excel data.

I am now looking at a Visio VSTO add-in (doing it in VB.NET I am an amateur coder), can something like this be done in a Visio VSTO add-in with some code that is not much more complicated than this?

I am basically opening the Excel file, selecting a range on the Excel sheet, then pushing that sheet in to an array to work further with the data from memory.

Again thank you for this superuseful code!
Visio 2021 Professional