Calling to Excel 2010 from Visio 2010

[gregorj]

I'm attempting to write code in Excel using Visio VBA code. I have researched this extensively.

My goal is to insert two cell formulae that add manually selected cells together. The Excel spreadsheet workbook (Book1) is already open and unsaved, so there's only a need to recognize the open workbook and the relevant code module (Module name is Sheet1; tab names are Path Analytics and Task Analytics). The code belongs in the code module for the Path analytics tab.

Variables nwSheet and UFvbc are never assigned and show "Subscript out of range".

Here's what I have written which is a compilation of info gathered from forums:

Sub TransferToExcel()
    Dim nwSheet As Excel.Worksheet
    Dim UFvbc As VBComponent
    Dim name As String
    Dim Code As String

    name = "Task Analytics"
    Set nwSheet = Excel.Application.Workbooks("Book1").Sheets(name)
    nwSheet.name = name
    DoEvents
    On Error Resume Next
    Set UFvbc = Excel.Application.ActiveWorkbook.VBProject.VBComponents(nwSheet.CodeName)
    MsgBox ("Test4")
   
    Dim count As Integer
    count = UFvbc.CodeModule.CountOfLines + 1
    Code = "Private Sub Worksheet_Change(ByVal Target as Range)" & vbCr
    Code = Code & "Private Sub Worksheet_SelectionChange(ByVal Target As Range)" & Chr(13)
    Code = Code & "    If ActiveSheet.Name = """ & "Path Analytics" & """ Then" & Chr(13)
    Code = Code & "        If Mid(Selection.Address, 2, 1) = """ & "C" & """ Then" & Chr(13)
    Code = Code & "            Cells(31, 3) = """ & "=Sum(" & """ & Selection.Address & """ & ")""" & Chr(13)
    Code = Code & "        ElseIf Mid(Selection.Address, 2, 1) = """ & "D" & """ Then & Chr(13)"
    Code = Code & "            Cells(31, 4) = """ & "=Sum(" & """ & Selection.Address & """ & ")""" & Chr(13)
    Code = Code & "        Else" & Chr(13)
    Code = Code & "            Cells(31, 3) = """ & """ & Chr(13)"
    Code = Code & "            Cells(31, 4) = """ & """ & Chr(13)"
    Code = Code & "        End if" & Chr(13)
    Code = Code & "    End If" & Chr(13)
    Code = Code & "End Sub" & Chr(13)
    UFvbc.CodeModule.InsertLines count, Code

End Sub

[Surrogate]

try

Code Select Expand

Set xlApp = GetObject(, "Excel.Application") instead

Code Select Expand

Set xlApp = Excel.Application
if you need change formulaes in some workbook cells why you use VBE ?

[Surrogate]

this code write simple code to excel workbook

Code Select Expand

Sub TransferToExcel()
    Dim VBP As VBIDE.VBProject
    Dim VBC As VBIDE.VBComponent
    Dim SL As Long, EL As Long, SC As Long, EC As Long
    Dim s As String
    Dim Found As Boolean
    Dim xlApp As Object
    Dim xlWb As Object
    Dim thisPath As String

    On Error Resume Next
    Set xlApp = GetObject(, "Excel.Application")
    Dim nwSheet As Excel.Worksheet
    Dim UFvbc As VBComponent
    Dim name As String
    Dim Code As String

    name = "Path Analytics"
    Set nwSheet = xlApp.ActiveWorkbook.Sheets(name)
    DoEvents
    On Error Resume Next
    Set UFvbc = xlApp.ActiveWorkbook.VBProject.VBComponents(nwSheet.CodeName)
   
    Dim count As Integer
    count = UFvbc.CodeModule.CountOfLines + 1
    Code = Code & "Private Sub Worksheet_SelectionChange(ByVal Target As Range)" & Chr(13)
    Code = Code & "End Sub" & Chr(13)
    UFvbc.CodeModule.InsertLines count, Code
End Sub

that your code make wrong macro in excel. check it please

Code Select Expand

Code = "Private Sub Worksheet_Change(ByVal Target as Range)" & vbCr
' where is end sub ?
    Code = Code & "Private Sub Worksheet_SelectionChange(ByVal Target As Range)" & Chr(13)
    Code = Code & "    If ActiveSheet.Name = """ & "Path Analytics" & """ Then" & Chr(13)
    Code = Code & "        If Mid(Selection.Address, 2, 1) = """ & "C" & """ Then" & Chr(13)
    Code = Code & "            Cells(31, 3) = """ & "=Sum(" & """ & Selection.Address & """ & ")""" & Chr(13)
    Code = Code & "        ElseIf Mid(Selection.Address, 2, 1) = """ & "D" & """ Then & Chr(13)"
    Code = Code & "            Cells(31, 4) = """ & "=Sum(" & """ & Selection.Address & """ & ")""" & Chr(13)
    Code = Code & "        Else" & Chr(13)
    Code = Code & "            Cells(31, 3) = """ & """ & Chr(13)"
    Code = Code & "            Cells(31, 4) = """ & """ & Chr(13)"
    Code = Code & "        End if" & Chr(13)
    Code = Code & "    End If" & Chr(13)
    Code = Code & "End Sub" & Chr(13)

[gregorj]

Thank you so much for that, Russian Visio Forum. along with File -> Options -> Trust Center -> Trust Center Setttings -> Macro Settings -> Trust Access to the VBA Project object model, it solved the problem!