part of a code not being executed

[Valeria]

Dear experts,
I have a problem with a block of code not being executed by Excel. It is a
code to write some VBA script in another workbook on the same sheet, it has
2 parts: the first one to write a Worksheet_SelectionChange sub and the
second one is to write a Worksheet_Change sub.
No matter in which order I put the script, the Worksheet_SelectionChange
part is always ingnored...
Can you pls help me?
Many thanks,
Best regards,
Valeria

option explicit
sub Valeria()
Dim StartLine As Long
Dim wsname As String
Workbooks(Montly_Report).Worksheets("Approvals").Activate
Range("a1").Select
wsname = ActiveWorkbook.Worksheets("Approvals").CodeName
With ActiveWorkbook.VBProject.VBComponents(wsname).CodeModule
StartLine = .CreateEventProc("SelectionChange", "Worksheet") + 1
.InsertLines StartLine, _
"Dim myRange As Range" & Chr(13) & _
"Set myRange = Range(""ID_Conf"")" & Chr(13) & _
"If Application.CellDragAndDrop = True And Application.Intersect(Target,
myRange) Is Nothing Or Application.CellDragAndDrop = True And Target.Text =
""Y"" Then" & Chr(13) & _
"Exit Sub" & Chr(13) & _
"ElseIf Application.Intersect(Target, myRange) Is Nothing = False And
Target.Text <> ""Y"" Then" & Chr(13) & _
"Application.CellDragAndDrop = false" & Chr(13) & _
"Else" & Chr(13) & _
"Application.CellDragAndDrop = true" & Chr(13) & _
"End If" & Chr(13)

StartLine = .CreateEventProc("Change", "Worksheet") + 1
.InsertLines StartLine, _
"dim vrange as range" & Chr(13) & "dim vvrange as range" & Chr(13) &
"dim vvvrange as range" & Chr(13) & _
"Dim Ans As Integer" & Chr(13) & "Dim cell As Object" & Chr(13) & _
"Set vrange = Range(""ID_Conf"")" & Chr(13) & "Set vvvrange =
Range(""Comment_Input"")" & Chr(13) & "Set vvrange =
Range(""Approval_Granted_For"")" & Chr(13) & _
"Me.Unprotect Password:=""anseladams""" & Chr(13) & _
"Application.EnableEvents = False" & Chr(13) & Chr(13) & _
"On Error Resume Next" & Chr(13) & _
"For Each cell In Target" & Chr(13) & _
"If Union(cell, vrange).Address = vrange.Address Then" & Chr(13) & _
" If cell.Value = ""Y"" Then" & Chr(13) & _
"Target.Offset(0, 1).Value = Application.UserName" & Chr(13) & _
"Target.Offset(0, 2).Value = Format(Date, ""DD-MMM-YYYY"")" & Chr(13) &
"Target.Offset(0, 3).Locked = False" & Chr(13) & _
"elseif cell.Value = ""N"" And cell.Offset(0, 5) <> """" then" & Chr(13)
& _
"Target.Offset(0, 1).Value = Application.UserName" & Chr(13) &
"Target.Offset(0, 2).Value = Format(Date, ""DD-MMM-YYYY"")" & Chr(13) & _
"Target.Offset(0, 3) = ""3""" & Chr(13) & "Target.Offset(0, 3).Locked =
True" & Chr(13) & _
"Target.Offset(0, 4) = Month(Now - 33 + 30*Target.Offset(0, 3)) & ""/""
& ""01/"" & Year(Now - 33 + 30)" & Chr(13) & _
"ElseIf cell.Value = ""N"" And cell.Offset(0, 5) = """" Then" & Chr(13)
& _
"Ans = MsgBox(""Before you can reject a violation, you must enter"" &
Chr(13) & ""an action plan (in the Actions column)!"", 16, ""PLEASE READ"")"
& Chr(13) & _
"cell.Value = """"" & Chr(13) & "Application.CellDragAndDrop = False" &
Chr(13) & " End If" & Chr(13) & _
"ElseIf Union(cell, vvrange).Address = vvrange.Address Then" & Chr(13) & _
"Target.Offset(0, 1).Value = Month(Now -33 + 30 * Target.Cells.Value) &
""/"" & ""01/"" & Year(Now -33 + 30 * Target.Cells.Value)" & Chr(13) & _
"ElseIf Union(cell, vvvrange).Address = vvvrange.Address Then" & Chr(13)
& Chr(13) & "if cell.EntireRow.Hidden = False then" & Chr(13) &
"cell.Comment.Delete" & Chr(10) & "cell.AddComment" & Chr(13) &
"cell.Comment.Visible = False" & Chr(13) & _
"cell.Comment.Text Text:=Application.UserName & Chr(10) & Format(Date,
""DD-MMM-YYYY"")" & Chr(13) & "cell.Comment.Shape.TextFrame.AutoSize = True"
& Chr(13) & _
"End If" & Chr(13) & "End If" & Chr(13) & "Next cell" & Chr(13) & "On
Error GoTo 0" & Chr(13) & "Application.enableevents = true" & Chr(13) & _
"Me.Protect Password:=""password"", DrawingObjects:=True,
Contents:=True, Scenarios:=True, AllowFormattingCells:=True,
AllowFormattingColumns:=false,AllowFormattingRows:=True, AllowSorting:=True,
AllowFiltering:=True"
End With
End Sub

 

[Bernie Deitrick]

Valeria,

Your code worked for me, putting both events into the codemodule.

I would recommend that you start with a clean workbook. Adding code to a workbook often causes
strange errors, and if you worked to develop this code in the same workbook that you are testing it
in, the garbage may have built up and make the code unworkable.

HTH,
Bernie
MS Excel MVP

 

[Valeria]

Hi,
thsi code is being executed from one workbook to a second one - it is part
of a much larger script.
As you say, I am getting really strange errors... is there a way I could
free up some memory from Excel or make it work smoother before beginning to
write code on the other workbook?

The other code looks like:
Call Start_Sub 'this is the macro that works on the other workbook but NOT
on its code
Call Write_VBA_For_Charts
Call CopyOneModule
Call First_Event_Macro
Call Second_Event_Macro
Call Valeria


Sub Write_VBA_For_Charts()

Dim StartLine As Long

Workbooks(WBReport).Activate
sname = ActiveWorkbook.Worksheets("Instructions").CodeName
With ActiveWorkbook.VBProject.VBComponents(sname).CodeModule
'I sometimes get an error here as Excel will ignore the attribution of the
value to
'the string sname (but the CodeName has well a value). How can this happen?
StartLine = .CreateEventProc("BeforeRightClick", "Worksheet") + 1
.InsertLines StartLine, _
"If Not Intersect(Target, Range(""d12:f12"")) Is Nothing Then" &
Chr(13) & _
" Cancel = True" & Chr(13) & _
"End If" & Chr(13) & _
"If Not Intersect(Target, Range(""d15:f15"")) Is Nothing Then" &
Chr(13) & _
" Cancel = True" & Chr(13) & _
"End If" & Chr(13) & _
"If Not Intersect(Target, Range(""d20:e20"")) Is Nothing Then" &
Chr(13) & _
" Cancel = True" & Chr(13) & _
"End If" & Chr(13)

StartLine = .CreateEventProc("SelectionChange", "Worksheet") + 1
.InsertLines StartLine, _
"If Not Intersect(Target, Range(""d12:f12"")) Is Nothing Then" &
Chr(13) & _
" On Error Resume Next" & Chr(13) & _
" Charts(""Chart1_Average PM Violation"").Activate" & Chr(13) & _
" If Err.Number <> 0 Then" & Chr(13) & _
" MsgBox ""No such chart exists."", vbCritical, ""Chart Not Found""
" & Chr(13) & _
"End If" & Chr(13) & _
"On Error GoTo 0" & Chr(13) & _
"End If" & Chr(13) & _
"If Not Intersect(Target, Range(""d15:f15"")) Is Nothing Then" &
Chr(13) & _
" On Error Resume Next" & Chr(13) & _
" Charts(""Chart2_Volume Split by PM Range"").Activate" & Chr(13) & _
"On Error GoTo 0" & Chr(13) & _
"End If" & Chr(13) & _
"If Not Intersect(Target, Range(""d20:e20"")) Is Nothing Then" &
Chr(13) & _
" On Error Resume Next" & Chr(13) & _
" Charts(""Chart3_Top 10 Violators"").Activate" & Chr(13) & _
" If Err.Number <> 0 Then" & Chr(13) & _
" MsgBox ""No such chart exists."", vbCritical, ""Chart Not Found""
" & Chr(13) & _
"End If" & Chr(13) & _
"On Error GoTo 0" & Chr(13) & _
"End If"
End With

End Sub

Sub CopyOneModule()

Dim FName As String
Workbooks(WBReport).Activate
Destination = ActiveWorkbook.Name
Origin = ThisWorkbook.Name
With Workbooks(Origin)
FName = .Path & "\code.txt"
.VBProject.VBComponents("Module1").Export FName
End With
Workbooks(Destination).VBProject.VBComponents.Import FName

End Sub


Sub First_Event_Macro()

Dim StartLine As Long
Workbooks(WBReport).Activate
With ActiveWorkbook.VBProject.VBComponents("ThisWorkbook").CodeModule
StartLine = .CreateEventProc("Open", "Workbook") + 1
.InsertLines StartLine, _
" Call MakeMenu"
End With
Workbooks(WBReport).Activate
End Sub


Sub Second_Event_Macro()
Workbooks(WBReport).Activate
With ActiveWorkbook.VBProject.VBComponents("ThisWorkbook").CodeModule
StartLine = .CreateEventProc("BeforeClose", "Workbook") + 1
.InsertLines StartLine, _
"Call DeleteMenu"
End With
Workbooks(WBMacro).Activate
End Sub

and the Valeria is below.

Many thanks for helping me out (I am getting desperate at this!)
Best regards
Valeria