Programmatically inserting a worksheet change event

T

Thebatfink

Active Member
Joined
Apr 8, 2007
Messages
410
Hi,

I'm trying to insert a worksheet change event using VBA. I have this sample code from here -

http://www.cpearson.com/Excel/vbe.aspx

Code: 
    Sub CreateEventProcedure()
        Dim VBProj As VBIDE.VBProject
        Dim VBComp As VBIDE.VBComponent
        Dim CodeMod As VBIDE.CodeModule
        Dim LineNum As Long
        Const DQUOTE = """" ' one " character

        Set VBProj = ActiveWorkbook.VBProject
        Set VBComp = VBProj.VBComponents("ThisWorkbook")
        Set CodeMod = VBComp.CodeModule
        
        With CodeMod
            LineNum = .CreateEventProc("Open", "Workbook")
            LineNum = LineNum + 1
            .InsertLines LineNum, "    MsgBox " & DQUOTE & "Hello World" & DQUOTE
        End With
    End Sub

I want to create the following a change event as below

Code: 
"Private Sub Worksheet_Change(ByVal Target As Range)"

I presume this is how you would code the Worksheet_Change, but how do I get my "(ByVal Target As Range)" in there??

Code: 
            LineNum = .CreateEventProc("Change", "Worksheet")

Also, all the other examples look for the last line in the sheets code, and start pumping the code in from the next line by defining LineNum as .CountOfLines + 1.. I have existing code in the sheets I'm trying to place this code into, do I need to worry about its placement and if so, how do I tell it where to place the code. In the example given for inserting a event procedure, LineNum is defined as .CreateEventProc from the start??

Thanks for any help!
Batfink
 

Excel Facts

Ambidextrous Undo
Undo last command with Ctrl+Z or Alt+Backspace. If you use the Undo icon in the QAT, open the drop-down arrow to undo up to 100 steps.
Sort by date Sort by votes
Try:

Rich (BB code): 
Sub CreateEventProcedure()
        Dim VBProj As VBIDE.VBProject
        Dim VBComp As VBIDE.VBComponent
        Dim CodeMod As VBIDE.CodeModule
        Dim LineNum As Long
        Const DQUOTE = """" ' one " character
        Set VBProj = ActiveWorkbook.VBProject
        Set VBComp = VBProj.VBComponents("Sheet1")
        Set CodeMod = VBComp.CodeModule
        
        With CodeMod
            LineNum = .CreateEventProc("Change", "Worksheet")
            LineNum = LineNum + 1
            .InsertLines LineNum, "    MsgBox " & DQUOTE & "Hello World" & DQUOTE
        End With
End Sub

I've highlighted the lines to change.

Dom

Dom
 
Upvote 0
CreateEventProc will insert the arguments for you - that's the whole point of using it. With this code:

Code: 
Sub CreateEventProcedure()
        Dim VBProj As VBIDE.VBProject
        Dim VBComp As VBIDE.VBComponent
        Dim CodeMod As VBIDE.CodeModule
        Dim LineNum As Long
        Const DQUOTE = """" ' one " character
        Set VBProj = ActiveWorkbook.VBProject
        Set VBComp = VBProj.VBComponents("Sheet1")
        Set CodeMod = VBComp.CodeModule
        
        With CodeMod
            LineNum = .CreateEventProc("Change", "Worksheet")
            LineNum = LineNum + 1
            .InsertLines LineNum, "    MsgBox " & DQUOTE & "Hello World" & DQUOTE
        End With
End Sub

I got:

Code: 
Private Sub Worksheet_Change(ByVal Target As Range)
    MsgBox "Hello World"
End Sub
 
Upvote 0
In answer to the rest of your question I think the code will just create the event code at the top of the page without overwriting what is already there. As you should only have one change procedure per worksheet it shouldn't matter where it goes.

Dom
 
Upvote 0
Thank you for the replies. Will get on it first thing in the morning.

Yes, no other change events, just other normal subs are present.

Thanks again!
 
Upvote 0
The code isn't working and I don't know why. Heres the code..

Code: 
Private Sub updatetest_click()

'dimension updater general variables

Dim myDir As String, fn As String, ws As Worksheet

'dimension command button code variables

Dim wsTarget As Worksheet
Dim objbutton As OLEObject

'dimension programatically editing VBA project variables and constants

Dim LineNum As Long
Dim VBProj As VBIDE.VBProject
Dim VBComp As VBIDE.VBComponent
Const DQUOTE = """"

'assign directory and filename wildcard variables for workbook loop

myDir = "path\to\my\files\"
fn = Dir(myDir & "*HM*.xls")

'check for existing files

If fn = "" Then
MsgBox "No Files Exist In Target Dir", 48, "Unable To Update": Exit Sub
End If

'begin workbook loop

Do While fn <> ""

'enable / disable application events and open workbook

Application.ScreenUpdating = True
Application.EnableEvents = True

Workbooks.Open myDir & fn
    
'add worksheet and position
    
    Sheets.Add.Name = "Summary"
    Sheets("Summary").Move After:=Worksheets(Worksheets.Count)

'insert summary command button and format

    Set wsTarget = Sheets("Summary")
    On Error Resume Next
    Set objbutton = wsTarget.OLEObjects.Add(ClassType:="Forms.CommandButton.1", Link:=False, _
    DisplayAsIcon:=False, Left:=2, Top:=2, Width:=153, Height:=42)

    With objbutton
    .Name = "cmbupdate"
    .Object.Caption = "Click to Update"
    End With
    
'cycle workbooks and assign variable dependant on sheetname

    For Each sh In ActiveWorkbook.Worksheets
        If sh.Name = "Monday" Then
            Set ws = sh
        ElseIf sh.Name = "Tuesday" Then
            Set ws2 = sh
        ElseIf sh.Name = "Wednesday" Then
            Set ws3 = sh
        ElseIf sh.Name = "Thursday" Then
            Set ws4 = sh
        ElseIf sh.Name = "Friday" Then
            Set ws5 = sh
        ElseIf sh.Name = "Saturday" Then
            Set ws6 = sh
        ElseIf sh.Name = "Sunday" Then
            Set ws7 = sh
        End If
    Next sh
    
'add new vba module
        
        Set VBProj = ActiveWorkbook.VBProject
        Set VBComp = VBProj.VBComponents.Add(vbext_ct_StdModule)
        VBComp.Name = "dirmodule"

'insert UNC/chdir API code into new module

        Set VBProj = ActiveWorkbook.VBProject
        Set VBComp = VBProj.VBComponents("dirmodule")
        Set CodeMod = VBComp.CodeModule
        With CodeMod
            LineNum = .CountOfLines + 1
.InsertLines LineNum, "Private Declare Function SetCurrentDirectoryA Lib ""kernel32"" (ByVal lpPathName As String) As Long"
            LineNum = LineNum + 1
.InsertLines LineNum, "Function ChDirAPI(strFolder As String) As Long"
            LineNum = LineNum + 1
.InsertLines LineNum, "ChDirAPI = SetCurrentDirectoryA(strFolder)"
            LineNum = LineNum + 1
.InsertLines LineNum, "End Function"
        End With

'assign tfile variable to target worksheet and insert worksheet_change event procedure into each daily sheet

tfile = ws.CodeName
        Set VBProj = ActiveWorkbook.VBProject
        Set VBComp = VBProj.VBComponents(tfile)
        Set CodeMod = VBComp.CodeModule
        With CodeMod
            LineNum = .CreateEventProc("Change", "Worksheet")
            LineNum = LineNum + 1
.InsertLines LineNum, "If Target.Column <> 6 Then Exit Sub"
            LineNum = LineNum + 1
.InsertLines LineNum, "If Target.Row < 6 Or Target.Row > 52 Then Exit Sub"
            LineNum = LineNum + 1
.InsertLines LineNum, "For Each cl In Target.Cells"
            LineNum = LineNum + 1
.InsertLines LineNum, "If cl <> "" Then"
            LineNum = LineNum + 1
.InsertLines LineNum, "Call soclink(cl.Row)"
            LineNum = LineNum + 1
.InsertLines LineNum, "Else"
            LineNum = LineNum + 1
.InsertLines LineNum, "If Cells(cl.Row, ""B"").Hyperlinks.Count > 0 Then"
            LineNum = LineNum + 1
.InsertLines LineNum, "Cells(cl.Row, ""B"").Hyperlinks.Delete"
            LineNum = LineNum + 1
.InsertLines LineNum, "Cells(cl.Row, ""B"").ClearContents"
            LineNum = LineNum + 1
.InsertLines LineNum, "End If"
            LineNum = LineNum + 1
.InsertLines LineNum, "End If"
            LineNum = LineNum + 1
.InsertLines LineNum, "Next cl"
        End With

Its dying here -

Code: 
            LineNum = .CreateEventProc("Change", "Worksheet")

I have checked the target worksheets in the open workbooks and there are definately no existing worksheet change events, and tfile is definately set - "Sheet2" when that part of the code is run..

Any ideas would be appreciated.

Thanks
James
 
Upvote 0
Ok.. So it turns out its not sorted..

It really doesn't like putting the worksheet change code into Sheet3..

Code: 
        Set VBComp = VBProj.VBComponents("Sheet2")

Works fine..

Code: 
        Set VBComp = VBProj.VBComponents("Sheet3")

Breaks..

I'm thinking a sheet numbering issue because worksheets have been deleted and moved around etc etc. Is it possible that what is shown in the VBA editor as a sheet called

Sheet3 (Mysheetname)

isn't actually Sheet3 at all?

------------
Scratch that, just checked and they are all numbered exactly the same. Can I even have a worksheet_change event in each sheet of a workbook??
 
Last edited:
Upvote 0
Thebatfink said:
Is it possible that what is shown in the VBA editor as a sheet called

Sheet3 (Mysheetname)

isn't actually Sheet3 at all?
Click to expand...

No, it's not.
------------
Scratch that, just checked and they are all numbered exactly the same. Can I even have a worksheet_change event in each sheet of a workbook??
Click to expand...

If you are using the same code in each, then it would be far easier to use a SheetChange event in the ThisWorkbook module. But yes, you can have a worksheet_change event in every sheet.
 
Upvote 0
Hi,

Sorry for the confusing posts.. I keep getting stuck, posting, then going back and having another stab at it, getting myself even more confused and reposting just outside of the edit window :)

I'd like to try and understand why this isn't working because as far as I can see, this SHOULD work?

This code is not working..

Code: 
Private Sub test1_click()

Dim myDir As String, fn As String
Dim wsTarget As Worksheet
Dim objbutton As OLEObject
Dim LineNum As Long
Dim VBProj As VBIDE.VBProject
Dim VBComp As VBIDE.VBComponent
Dim CodeMod As VBIDE.CodeModule
Const DQUOTE = """" ' one " character

myDir = "path\to\"
fn = Dir(myDir & "*filename*.xls")

Do While fn <> ""

Application.ScreenUpdating = True
Application.EnableEvents = True

Workbooks.Open myDir & fn
        
        Set VBProj = ActiveWorkbook.VBProject
        Set VBComp = VBProj.VBComponents.Add(vbext_ct_StdModule)

        Set VBProj = ActiveWorkbook.VBProject
        Set VBComp = VBProj.VBComponents("Module2")
        Set CodeMod = VBComp.CodeModule
        With CodeMod
            LineNum = .CountOfLines + 1
.InsertLines LineNum, "Private Declare Function SetCurrentDirectoryA Lib ""kernel32"" (ByVal lpPathName As String) As Long"
            LineNum = LineNum + 1
.InsertLines LineNum, "Function ChDirAPI(strFolder As String) As Long"
            LineNum = LineNum + 1
.InsertLines LineNum, "ChDirAPI = SetCurrentDirectoryA(strFolder)"
            LineNum = LineNum + 1
.InsertLines LineNum, "End Function"
        End With

        Set VBProj = ActiveWorkbook.VBProject
        Set VBComp = VBProj.VBComponents("Sheet2")
        Set CodeMod = VBComp.CodeModule
        With CodeMod
            LineNum = .CreateEventProc("Change", "Worksheet")
            LineNum = LineNum + 1
.InsertLines LineNum, "If Target.Column <> 6 Then Exit Sub"
            LineNum = LineNum + 1
.InsertLines LineNum, "If Target.Row < 6 Or Target.Row > 52 Then Exit Sub"
            LineNum = LineNum + 1
.InsertLines LineNum, "For Each cl In Target.Cells"
            LineNum = LineNum + 1
.InsertLines LineNum, "If cl <> """" Then"
            LineNum = LineNum + 1
.InsertLines LineNum, "Call soclink(cl.Row)"
            LineNum = LineNum + 1
.InsertLines LineNum, "Else"
            LineNum = LineNum + 1
.InsertLines LineNum, "If Cells(cl.Row, ""B"").Hyperlinks.Count > 0 Then"
            LineNum = LineNum + 1
.InsertLines LineNum, "Cells(cl.Row, ""B"").Hyperlinks.Delete"
            LineNum = LineNum + 1
.InsertLines LineNum, "Cells(cl.Row, ""B"").ClearContents"
            LineNum = LineNum + 1
.InsertLines LineNum, "End If"
            LineNum = LineNum + 1
.InsertLines LineNum, "End If"
            LineNum = LineNum + 1
.InsertLines LineNum, "Next cl"
        End With
        
        Set VBProj = ActiveWorkbook.VBProject
        Set VBComp = VBProj.VBComponents("Sheet3")
        Set CodeMod = VBComp.CodeModule
        With CodeMod
            LineNum = .CreateEventProc("Change", "Worksheet")
            LineNum = LineNum + 1
.InsertLines LineNum, "If Target.Column <> 6 Then Exit Sub"
            LineNum = LineNum + 1
.InsertLines LineNum, "If Target.Row < 6 Or Target.Row > 52 Then Exit Sub"
            LineNum = LineNum + 1
.InsertLines LineNum, "For Each cl In Target.Cells"
            LineNum = LineNum + 1
.InsertLines LineNum, "If cl <> """" Then"
            LineNum = LineNum + 1
.InsertLines LineNum, "Call soclink(cl.Row)"
            LineNum = LineNum + 1
.InsertLines LineNum, "Else"
            LineNum = LineNum + 1
.InsertLines LineNum, "If Cells(cl.Row, ""B"").Hyperlinks.Count > 0 Then"
            LineNum = LineNum + 1
.InsertLines LineNum, "Cells(cl.Row, ""B"").Hyperlinks.Delete"
            LineNum = LineNum + 1
.InsertLines LineNum, "Cells(cl.Row, ""B"").ClearContents"
            LineNum = LineNum + 1
.InsertLines LineNum, "End If"
            LineNum = LineNum + 1
.InsertLines LineNum, "End If"
            LineNum = LineNum + 1
.InsertLines LineNum, "Next cl"
        End With
        
        ActiveWorkbook.Save
Workbooks(fn).Close False
fn = Dir

Application.EnableEvents = True
Application.ScreenUpdating = True

Loop
End Sub

The code causes excel to crash.. If I change the lines

Code: 
        Set VBComp = VBProj.VBComponents("Sheet2")
        Set VBComp = VBProj.VBComponents("Sheet3")

to the following (as I thought maybe I should be using a SheetName rather than SheetCodeName for some reason... don't ask!)

Code: 
        Set VBComp = VBProj.VBComponents("Monday")
        Set VBComp = VBProj.VBComponents("Tuesday")

The code is pasted twice as I am trying to do, but all into Module2.

So from this, I believe I am not correctly focusing the worksheet code window to put these change events in..? The problem is, why? Because as Mr Poulsom said, the code is working for him when you tried it? Is it because I'm inserting the new module and populating it was code first??

Sheet Monday is definately Sheet2 and Tuesday is definately Sheet3, I checked with the following

Code: 
For Each sh in Activeworkbook.Worksheets
msgbox "" & sh.CodeName & Sh.Name & ""
Next sh

Thanks
James (with a lot less hair than when I started this morning)
 
Upvote 0
You must log in or register to reply here.

Similar threads

SeniorNewbie
  • Question Question
Problem with VBIDE.CodeModule
Replies
3
Views
330
Domenic
D
E
  • Solved
Convert Subroutine to Function?
Replies
8
Views
412
EssKayKay
E
J
  • Question Question
Inserting picture into cell via VBA
Replies
2
Views
862
Joek88
J
A
  • Question Question
Worksheet Change Event Triggering With Cell Validation "Cancel"
Replies
1
Views
582
rlv01
R
S
  • Solved
Worksheet Change Event
Replies
3
Views
597
sspatriots
S

Forum statistics

Threads
1,224,820
Messages
6,181,154
Members
453,021
Latest member
Justyna P

Share this page

We've detected that you are using an adblocker.

We have a great community of people providing Excel help here, but the hosting costs are enormous. You can help keep this site running by allowing ads on MrExcel.com.
Allow Ads at MrExcel

Which adblocker are you using?

Disable AdBlock

Follow these easy steps to disable AdBlock

1)Click on the icon in the browser’s toolbar.
2)Click on the icon in the browser’s toolbar.
2)Click on the "Pause on this site" option.
Go back

Disable AdBlock Plus

Follow these easy steps to disable AdBlock Plus

1)Click on the icon in the browser’s toolbar.
2)Click on the toggle to disable it for "mrexcel.com".
Go back

Disable uBlock Origin

Follow these easy steps to disable uBlock Origin

1)Click on the icon in the browser’s toolbar.
2)Click on the "Power" button.
3)Click on the "Refresh" button.
Go back

Disable uBlock

Follow these easy steps to disable uBlock

1)Click on the icon in the browser’s toolbar.
2)Click on the "Power" button.
3)Click on the "Refresh" button.
Go back
Back
Top