vba Change Macro not firing consistantly

[Jesienouski]

First post, so be kind. I have a change macro within a large workbook that is not firing consistantly. The change will fire the first time the workbook is opened and the change takes place, but then stops working after that. Does anyone know what is going on? I can send the workbook if needed, but it is almost 6 megs. I'm working in '07 if that helps too.

 

[GlennUK]

Show your change macro.

 

[VoG]

Try posting your change macro code.

 

[Jesienouski]

Thanks for the quick response. Here is the code:

Private Sub Worksheet_Change(ByVal Target As Range)

Dim Rng As Range
Dim JIRA As String
Dim JIRALoc As String
Dim JIRAbln As Boolean
Dim YesNo As String
'Pulls up the Calendar for the Script Writing Date and the Script Execution Date
If Target.Address = Sheet28.Range("H7").Address Then
Application.EnableEvents = False
frmCalendar3.Show
Application.EnableEvents = True
Else
If Target.Address = Sheet28.Range("H9").Address Then
Application.EnableEvents = False
frmCalendar4.Show
Application.EnableEvents = True
Else
End If
End If

If Sheet29.Range("Pause_Status") = 1 Then
YesNo = MsgBox("Your script is paused, Do you want to resume?", vbYesNo)
If YesNo = vbYes Then
Run ("Pause_Resume")
Else
End If
Else
End If
JIRALoc = Sheet29.Cells(5, 5).Value
If JIRALoc = "" Then
JIRAbln = False
Else
JIRAbln = True
End If

Set Rng = Sheet28.Range("F1:F1000") ' change range as required
'If Not Intersect(Target, Rng) Is Nothing Then
If Intersect(Target, Rng) Is Nothing Then
'do nothing
Else
If Target.Value = "Pass" Then
Target.Offset(0, 3).Value = Application.UserName & " " & Now
Else
End If
If Target.Value = "Fail" Then
Target.Offset(0, 3).Value = Application.UserName & " " & Now
If JIRAbln = True Then
JIRA = MsgBox("Do you need to input a defect in your defect tracking system for this issue?", vbYesNo)
If JIRA = vbYes Then
ThisWorkbook.FollowHyperlink (JIRALoc)
End If
End If
Else
End If
If IsEmpty(Target.Value) Then
Target.Offset(0, 3).ClearContents

Else
End If
End If

End Sub

 

[RoryA]

Do you get any errors? What is the code for Pause_Resume?

 

[Jesienouski]

Sorry about this, I do not get any errors, it seems that the code just stops executing. If I close down the workbook and re-open it the change will fire on the first change and then stops. The Pause_Resume code is a timestamp feature that we are working on to attempt to track how long it is taking our people to write their scripts for testing. The code is below:

Sub Pause_Resume()
Range("Pause_Status").Value = 0
ActiveSheet.Shapes("Button 5").Select
Selection.Characters.Text = "Pause"

I = 3
Do Until IsEmpty(Sheet30.Cells(I, 2))
If IsEmpty(Sheet30.Cells(I, 2).Offset(1, 0)) Then
Set LastCell = Sheet30.Cells(I, 2).Offset(1, 0)
Else
End If
I = I + 1
Loop

LastCell.Value = Now

Sheet28.Cells(11, 3).Select
End Sub

 

[RoryA]

See if this works better:

Private Sub Worksheet_Change(ByVal Target As Range)

   Dim Rng As Range
   Dim JIRA As String
   Dim JIRALoc As String
   Dim JIRAbln As Boolean
   Dim YesNo As String
   
   On Error GoTo err_handle
   Application.EnableEvents = False

   'Pulls up the Calendar for the Script Writing Date and the Script Execution Date
   If Target.Address = Sheet28.Range("H7").Address Then
      frmCalendar3.Show
   Else
      If Target.Address = Sheet28.Range("H9").Address Then
         frmCalendar4.Show
      End If
   End If

   If Sheet29.Range("Pause_Status") = 1 Then
      YesNo = MsgBox("Your script is paused, Do you want to resume?", vbYesNo)
      If YesNo = vbYes Then
         Run "Pause_Resume"
      End If
   End If
   JIRALoc = Sheet29.Cells(5, 5).Value
   If JIRALoc = "" Then
      JIRAbln = False
   Else
      JIRAbln = True
   End If

   Set Rng = Sheet28.Range("F1:F1000")   ' change range as required
   'If Not Intersect(Target, Rng) Is Nothing Then
   If Intersect(Target, Rng) Is Nothing Then
      'do nothing
   Else
      If Target.Value = "Pass" Then
         Target.Offset(0, 3).Value = Application.UserName & " " & Now
      Else
      End If
      If Target.Value = "Fail" Then
         Target.Offset(0, 3).Value = Application.UserName & " " & Now
         If JIRAbln = True Then
            JIRA = MsgBox("Do you need to input a defect in your defect tracking system for this issue?", vbYesNo)
            If JIRA = vbYes Then
               ThisWorkbook.FollowHyperlink (JIRALoc)
            End If
         End If
      Else
      End If
      If IsEmpty(Target.Value) Then
         Target.Offset(0, 3).ClearContents

      Else
      End If
   End If

clean_up:
   Application.EnableEvents = True
   Exit Sub
   
err_handle:
   MsgBox Err.Description
   Resume clean_up
End Sub

 

[Jesienouski]

That appears to have solved it. However, I am getting an error now when I do the change on cell "H9". A dialog box appears and says "Object Required". I'm not sure what that is now though. The change in that cell opens frmCalendar4 its code is below, could that have something to do with it?

Private Sub Calendar4_Click()
    Sheet28.Select
    Sheet28.Range("H9").Value = Calendar4.Value
    Unload Me
    Sheet28.Range("H9").Select
End Sub
 
Private Sub cmdClose_Click()
    Unload Me
    Range("H9").Select
End Sub
 
Private Sub UserForm_Initialize()
        If IsDate(Sheet28.Range("H9").Value) Then
            Calendar4.Value = DateValue(ActiveCell.Value)
        Else
            Calendar4.Value = Date
        End If
End Sub

Also, can I ask what you did? I see the cleanup commands at the bottom, what do those do? Thanks again!

 

[RoryA]

Which line causes the error?

Your code was making changes to the sheet, which was triggering the change event all over again, so you end up in a loop. I simply disabled events once at the start then re-enabled them at the end.

 

[Jesienouski]

I'm not sure which line in the code causes the error, I'm assuming that it's this part, but I'm not sure why because the code right above that seems fine.

   Else
      If Target.Address = Sheet28.Range("H9").Address Then
         frmCalendar4.Show
      End If

When I change the value in cell H9 on the worksheet the box pops up and says "Object Required". The change to cell H7 that executes simillar code seems to be working fine. Again, thanks for the help!