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
try Set xlApp = GetObject(, "Excel.Application")
instead Set xlApp = Excel.Application
if you need change formulaes in some workbook cells why you use VBE ?
this code write simple code to excel workbook
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 = "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)
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!