Adding code to worksheet module

The attachment is based on DRJ's extremely useful "Find all words in Excel" KB submission. For my purpose, I want to use it in a single workbook. The code as modified now adds a worksheet called "FindWord" to the active workbook, containing the information links etc. What I want to do is to add some code to this sheet, which will do another search when the search term in cell B1 is changed.
Problem is, I don't know much about adding VBComponents and referencing them:bawl
The attachment should run once, to show what should happen, but I'm having to reference FindWord as Sheet4, which may not always be true.
Secondly, I really want to put the search module into Personal.xls, so that I can call it from any spreadsheet. The further problem there is the "ActiveVBProject" (I think) which wants to write the code to a module in Personal.xls.
Any assistance greatly appreciated!
Regards,
MD

Code:

---

Sub ExportCodeMod()
Dim strCode As String
'Code to be written to "FindWord"
'Private Sub Worksheet_Change(ByVal Target As Range)
'If Target.address = "$B$1" Then
'Application.Run ("Personal.xls!Search.FindAll"), Target.Text, "False"
'Cells(1, 2).Select
'End if
'End Sub

---

'Line to be inserted instead of 3rd line below to run from Personal.xls

Code:

---

'& "Application.Run (" & Chr(34) & "Personal.xls!Search.FindAll" & Chr(34) & "), Target.Text, " & Chr(34) & "False" & Chr(34) & vbCr _
strCode = "Private Sub Worksheet_Change(ByVal Target As Range)" & vbCr _
& "If Target.Address = " & Chr(34) & "$B$1" & Chr(34) & " Then" & vbCr _
& "FindAll Target.Text, " & Chr(34) & "False" & Chr(34) & vbCr _
& "Cells(1,2).Select" & vbCr _
& "End if" & vbCr _
& "End Sub"
 
Application.VBE.ActiveVBProject.VBComponents.Item("Sheet4") _
.CodeModule.AddFromString (strCode)
End Sub

---

This is the basic code for doing what you want. Make your new workbook the activeworkbook and run this code. The code that is added in in the form of one long string. That's why I have a line of code then & CHR(13) & Next line of code. Let me know if you have any problem implementing it.

NOTE: Make sure you save prior to running any of this code. If you get something that the vba editor would choke on, then Excel will crash(At least in 97). You will also need to set a reference to VBA Extensibility lib.(Or change the code to late binding)

HTH

Code:

---

Dim WB1 As Workbook
Dim WS1 As Worksheet
Dim MD As VBComponent
Dim PD As CodeModule
Dim LineNumber As Long
Dim CmdBut As msforms.CommandButton
Set WB1 = ActiveWorkbook
Set WS1 = ActiveSheet
'Sets up a new module based on MD
Set MD = WB1.VBProject.VBComponents.Add(vbext_ct_StdModule)
MD.Name = "Module1"
Application.Visible = True
'Add Code to Module
Set PD = WB1.VBProject.VBComponents(MD.Name).CodeModule
With PD
    LineNumber = .CountOfLines + 1
      .InsertLines LineNumber, _
    "Public BarNames(30) as String" & Chr(13) & "Public Counter As Integer" & Chr(13) & _
End With

---

Hi CBrine,
My code creates a worksheet which appears in the Project Explorer as
Sheet4(FindWord) or Sheet5(FindWord) etc., depending upon the workbook.
The code I want to run is triggered by a WorkSheet change, so I have to get my code into that Worksheet module, a standard module won't work.
I'm fiddling with code such as

Code:

---

Application.WB1.VBProject.VBComponents.Item("FindWord") _
      .CodeModule.AddFromString (strCode)

---

but I'm not sure if I have to find the correct sheet number for FindWord, and insert that instead.
MD

This should work for you.

Code:

---

Dim WB1 As Workbook
Dim WS1 As Worksheet
Dim MD As VBComponent
Dim PD As CodeModule
Dim LineNumber As Long
Set PD = WB1.VBProject.VBComponents("ThisWorkbook").CodeModule
With PD
    LineNumber = .CountOfLines + 1
    .InsertLines LineNumber, _
    "Private Sub Workbook_SheetSelectionChange(ByVal Sh As Object, ByVal Target As Range)" & Chr(13) & "application.cutcopymode =false" & Chr(13) & "End Sub" & chr(13) & _  'Your next event title would go here if you were doing more then one event.

---

Hi CBrine,
Based on your components, the following works

Code:

---

WB1.VBProject.VBComponents.Item("sheet4").CodeModule.AddFromString (strCode)

---

so I just need to find determine the link between the Sheet# and the Name. Project Explorer shows two name values for a Sheet module
MD

mdmackillop,
Sorry that last post was for the workbook event's. For worksheet events your should be able to just change this

Code:

---

Set WS1 = ActiveSheet

---

to this

Code:

---

Set ws1 = sheets("FindWord")

---

and it should cycle down by itself.

Md,
I remember what you are talking about now. I remember dealing with on something as well. The module name and worksheet name don't need to match. I did come up with a solution to this, but I can't remember exactly what I did. Let me check in some of my sample code to see if I can find it.

Sample code? SAMPLE CODE???
And it's not in our KB??
Hee hee....

Somehow, CBrine, your post threw an error into the forum database. Weird.

Yeah, I saw that. I'm using slim browser as my browser, don't know if that might be what's causing the trouble. I think I might have trojan lurking around on my system as well, so you never know what it's doing.

Hi CBrine,
Getting closer. It works if I step through it, but not when it runs :confused:
MD

Code:

---

FWord = WB1.Sheets("FindWord").CodeName
WB1.VBProject.VBComponents.Item(FWord).CodeModule.AddFromString (strCode)

---

It seems to come down to this. In a workbook, if I rename a sheet manually, ExportCode will run. If I add a sheet using MakeSheet, it will not. (Excel 2000)

Code:

---

Sub MakeSheet()
On Error Resume Next
Sheets("FindWord").Select
If Err = 9 Then
Sheets.Add
ActiveSheet.name = "FindWord"
End If
End Sub

 
Sub ExportCode()
Dim WB1 As Workbook
Dim strCode As String
Dim FWord As String
Set WB1 = ActiveWorkbook
strCode = "Private Sub Worksheet_Change(ByVal Target As Range)" & vbCr _
& "If Target.Address = " & Chr(34) & "$B$1" & Chr(34) & " Then" & vbCr _
& vbTab & "Application.Run (" & Chr(34) & "Personal.xls!Search.FindAll" & Chr(34) & "), Target.Text, " & Chr(34) & "False" & Chr(34) & vbCr _
& vbTab & "Cells(1,2).Select" & vbCr _
& "End if" & vbCr _
& "End Sub"
FWord = WB1.Sheets("FindWord").CodeName
MsgBox FWord
WB1.VBProject.VBComponents.Item(FWord).CodeModule.AddFromString (strCode)
End Sub

---

See http://www.vbaexpress.com/forum/showthread.php?t=931 for a solution.