Runtime procedure 1

[Jofx]

May VBA code creates a new sheet at runtime inside an XL workbook.
I 'd like to assign a event procedure to that sheet (ex: Sub Worksheet_Activate) dynamically.

Is it possible ?

Thanks
Jofx

 

[rmikesmith]

Yes, it is possible. Here is an example procedure to do what you want:

Sub CreateNewSheetWithEvent()
Dim Wks As Worksheet
Dim SheetCodename As String
Dim SheetCodeModule As CodeModule
Dim CodeLine As Integer


   Set Wks = ThisWorkbook.Worksheets.Add
   SheetCodename = Wks.CodeName
   
   Set SheetCodeModule = ThisWorkbook.VBProject.VBComponents(SheetCodename).CodeModule
   
   With SheetCodeModule
     CodeLine = .CountOfLines + 1
   
     .InsertLines CodeLine, "Private Sub Worksheet_Activate()"
     CodeLine = CodeLine + 1
     .InsertLines CodeLine, EventCode_Line1
    ' ...
     CodeLine = CodeLine + 1
     .InsertLines CodeLine, EventCode_LineN
     CodeLine = CodeLine + 1
     .InsertLines CodeLine, "End Sub"

   End With
   
   Set SheetCodeModule = Nothing
   Set Wks = Nothing
   
End Sub

Notes:
This requires a reference (Tools|References...) to the Micorsoft Visual Basic for Applications Extensibility library.
EventCode_Line1..EventCode_LineN represent string constants containing the code you want included in the event handler. You could, of course use string literals, an array of strings, etc.

I have tested this and it works.


Regards,
Mike

 

[Jofx]

Thanks a lot Mike, it looks like simple.
Jofx

 

[SkipVought]

Nice Mike! ==>*

Have you written an FAQ on this?

Skip,

_{[red]Be Advised![/red] A chicken, who would drag a wagon across the road for 2 cents, is…
POULTRY in motion to PULLET for a PALTRY amount!}

 

[rmikesmith]

Thank you, Skip.

No, I haven't written a FAQ but thanks to your nudge perhaps I'll put one together.


Regards,
Mike

 

[Jofx]

Mike,

I used your code and encounter a bug when closing and re-open XL.
I run the following sample, save the sheet, close XL, re-open it, re-run the test, and a error message happens (#9)

When I just close the sheet without closing XL, no error happens.

Any idea ?
Thanks in advance
Jofx

sample:
in sheet 1, place a button to launch the Newsheet proc.

Sub Newsheet()
Dim Wks As Worksheet
Dim SheetCodename As String
Dim SheetCodeModule As CodeModule
Dim CodeLine As Integer

' If Test sheet exists, delete
If ExistingSheet("Test") = True Then
Application.DisplayAlerts = False
ActiveWorkbook.Sheets("Test").Delete
End If

Set Wks = ThisWorkbook.Worksheets.Add
SheetCodename = Wks.CodeName
Wks.Name = "Test"

' Bug here after closing XL, re-open and run it
' ----------------------------------------------------------------------------------
Set SheetCodeModule = ThisWorkbook.VBProject.VBComponents(SheetCodename).CodeModule
' ----------------------------------------------------------------------------------

With SheetCodeModule
CodeLine = .CountOfLines + 1
.InsertLines CodeLine, "Private Sub Worksheet_Activate()"
CodeLine = CodeLine + 1
.InsertLines CodeLine, "msgbox time"
CodeLine = CodeLine + 1
.InsertLines CodeLine, "End Sub"
End With

Set SheetCodeModule = Nothing
Set Wks = Nothing

End Sub


Public Function ExistingSheet(SheetName)
Dim Ob As Object
On Error Resume Next
Set Ob = ActiveWorkbook.Sheets(SheetName)
If Err = 0 Then ExistingSheet = True Else ExistingSheet = False
End Function

 

[rmikesmith]

Jofx,

I am able to duplicate the error condition but don't know what the cause is, yet. I'll work on this and post back.


Regards,
Mike

 

[HughLerwill]

I am late in catching the start of this thread and appreciate the discussion has moved on but to add procedures code along the lines of;

a$ = "Private Sub Workbook_Open()" & vbCr & _
"With ActiveSheet" & vbcr & _
".PageSetup.Orientation = xlLandscape" & vbcr & _
".PageSetup.FitToPagesWide = 1" & vbcr & _
".PageSetup.LeftFooter = ""targetWorkSheetName""" & vbcr & _
"End With" & vbcr & _
"End Sub"

ActiveWorkbook.VBProject.VBComponents.Item("ThisWorkbook").CodeModule.AddFromString (a$)

is also worth trying as discussed in thread707-1167069.

Hugh,

 

[rmikesmith]

Jofx,

This is certainly a strange error. I have no good explanation for why this is happening. However, I have discovered that under the conditions leading to the error, the offending line of code will work the next time executed. Therefore, here is a fix based on trapping the error then retrying:

Sub Newsheet()
Dim Wks As Worksheet
Dim SheetCodeModule As CodeModule
Dim CodeLine As Integer
Dim counter As Integer
    
    [COLOR=green]' If Test sheet exists, delete[/color]
    If ExistingSheet("Test") = True Then
        Application.DisplayAlerts = False
        ActiveWorkbook.Sheets("Test").Delete
    End If
    
    Set Wks = ThisWorkbook.Worksheets.Add
    
    Wks.Name = "Test"
    
    On Error Resume Next
    counter = 0

    Do
      Err.Clear
      Set SheetCodeModule = ThisWorkbook.VBProject.VBComponents(Wks.CodeName).CodeModule
   counter = counter + 1    
   Loop Until (Not SheetCodeModule Is Nothing) Or counter = 10
    If Err.Number <> 0 Then
      [COLOR=green]'Message to the user here?[/color]
      Exit Sub
    End If
    On Error GoTo 0  [COLOR=green]'or On Error GoTo YourErrorHandlerLabel[/color]
    
    With SheetCodeModule
         CodeLine = .CountOfLines + 1
         .InsertLines CodeLine, "Private Sub Worksheet_Activate()"
         CodeLine = CodeLine + 1
         .InsertLines CodeLine, "msgbox time"
         CodeLine = CodeLine + 1
         .InsertLines CodeLine, "End Sub"
     End With
    
    Set SheetCodeModule = Nothing
    Set Wks = Nothing
  
End Sub

Note: As a defense against an infinite loop condition, I've included a counter as a secondary exit condition (the value of 10 is arbitrary).


Regards,
Mike