Hi!

I am creating the worksheets dynamically at runtime. Now, I want to add
the event procedures there itself as soon as I am creating the sheets .
I have tried it by the 2 ways.

1. By the method CreateEventProc -
2. By InsertLines method only - Due the 1. take the focus to vbe

Well, both works fine if we work on one sheet only, but since my
requirment is quite different.
I am adding the sheets in loop, and there i am using the above methods,
but it works one time, and the code doesn;t run after InsertLines code
completes. The excel doesn't response itself, and closes.

Here are my code please check it..

Private Sub CommandButton1_Click()
Dim iCnt As Integer
Dim sName As String
For iCnt = 1 To 5
sName = "Sample_" & iCnt
Sheets.Add(Befo=Worksheets("Sample")).Name = sName
If Not ProcedureExists("Worksheet_Change",
Worksheets(sName).CodeName) Then
Dim ChangeModule
Dim CodeString
Set ChangeModule = Workbooks("Book1.xls").VBProject
'Line1 =
ChangeModule.VBComponents(Worksheets(sName).CodeNa me).CodeModule.CreateEventProc("Change",
"Worksheet")
CodeString = "Private Sub Worksheet_Change(ByVal Target As
Range)"
CodeString = CodeString & vbLf & "'Testing..."
'CodeString = CodeString & vbLf & "MsgBox ""You have
changed the cell "" & Replace(Target.Address, ""$"", """")"
CodeString = CodeString & vbLf & "MsgBox ""TEST"""
CodeString = CodeString & vbLf & "End Sub"

ChangeModule.VBComponents(Worksheets(sName).CodeNa me).CodeModule.InsertLines
1, CodeString
'Worksheets(sName).Activate
MsgBox "ddd"
Else
MsgBox "The change event is already exists in the sheet " &
sName
End If
Next
End Sub


Function ProcedureExists(ProcedureName As String, _
ModuleName As String) As Boolean
On Error Resume Next
ProcedureExists = ThisWorkbook.VBProject.VBComponents(ModuleName) _
.CodeModule.ProcStartLine(ProcedureName, vbext_pk_Proc) < 0
End Function


I would be very thankfull if anyone could help me..

Thanks in advance!

First, I would move your two Dim's out of the loop to the top of the proc.

I'm pretty sure the main problem is adding event code multiple times. Eg, no
problem if you change the first code line.

CodeString = "Private Sub Worksheet_Change(ByVal Target As Range)"
to
CodeString ="Sub MyMacro()"

I guess the it's related to the project trying to compile in the process.
Similar can occur if adding worksheet controls within the same project,
though not if in another project. Your routine though also appears to fail
even if adding sheets & their event code to another project.

Hopefully someone will suggest a fix. In the meantime I would suggest do not
run in a loop.

That would entail getting user to run the code individually for each new
sheet. Something to determine an unnamed sheet Sample_X. Probably want to
set a reference to the original sheet and re-activate each time.

Regards,
Peter T


wrote in message
ups.com...
Hi!

I am creating the worksheets dynamically at runtime. Now, I want to add
the event procedures there itself as soon as I am creating the sheets .
I have tried it by the 2 ways.

1. By the method CreateEventProc -
2. By InsertLines method only - Due the 1. take the focus to vbe

Well, both works fine if we work on one sheet only, but since my
requirment is quite different.
I am adding the sheets in loop, and there i am using the above methods,
but it works one time, and the code doesn;t run after InsertLines code
completes. The excel doesn't response itself, and closes.

Here are my code please check it..

Private Sub CommandButton1_Click()
Dim iCnt As Integer
Dim sName As String
For iCnt = 1 To 5
sName = "Sample_" & iCnt
Sheets.Add(Befo=Worksheets("Sample")).Name = sName
If Not ProcedureExists("Worksheet_Change",
Worksheets(sName).CodeName) Then
Dim ChangeModule
Dim CodeString
Set ChangeModule = Workbooks("Book1.xls").VBProject
'Line1 =

ChangeModule.VBComponents(Worksheets(sName).CodeNa me).CodeModule.CreateEvent
Proc("Change",
"Worksheet")
CodeString = "Private Sub Worksheet_Change(ByVal Target As
Range)"
CodeString = CodeString & vbLf & "'Testing..."
'CodeString = CodeString & vbLf & "MsgBox ""You have
changed the cell "" & Replace(Target.Address, ""$"", """")"
CodeString = CodeString & vbLf & "MsgBox ""TEST"""
CodeString = CodeString & vbLf & "End Sub"


ChangeModule.VBComponents(Worksheets(sName).CodeNa me).CodeModule.InsertLines
1, CodeString
'Worksheets(sName).Activate
MsgBox "ddd"
Else
MsgBox "The change event is already exists in the sheet " &
sName
End If
Next
End Sub


Function ProcedureExists(ProcedureName As String, _
ModuleName As String) As Boolean
On Error Resume Next
ProcedureExists = ThisWorkbook.VBProject.VBComponents(ModuleName) _
.CodeModule.ProcStartLine(ProcedureName, vbext_pk_Proc) < 0
End Function


I would be very thankfull if anyone could help me..

Thanks in advance!