Userform intermittently not loading and then causing an issue with constant calculation.

S

Snayff

New Member
Joined
Nov 24, 2015
Messages
18
Hello all,

This forum has been an absolute blessing to me for a long time now, answering the (seemingly) unanswerable. However, I have hit a stump with this one.

Preamable
The whole project is fairly sizable (though it's all relative) but has been developed to be fairly modular. I will just highlight the elements I expect pertain to the problem but please let me know if I need to broaden the explanation.
Also, I will try to use the correct terms, but my apologies in advance if I use the wrong label for something - I have learnt completely through online forums, often a risky proposition when it comes to having a robust understanding.

Steps before the problem
I have an Excel ('03) front end with an Access ('03) database.
1.The data is recalled from the database and placed in the ReviewSheet.
2. I then double click on the ID number, which pulls the information for the relevant record on to the UpdateSheet.
3. Doing so then opens the UpdateForm.
This all populates fine.

Breakdown of the problem
Occassionally the userform appears (that is, the outline appears, with the header and red X) but is solid grey in the centre. If I hit the red X to close it then appears normally. However, when I close that instance of the form (which reverts to the ReviewSheet) and I am then left with the workbook constantly recalculating. At no other time does this happen, the worksheet_Activate event for ReviewSheet doesnt have anything that would lead to looping (to my knowledge).

Checks completed
  • Stepped through all the relevant code
  • Stripped out all additional, or nice-to-have, features
  • Tested a variety of conditions

Last notes
I expect the code to be messy and somewhat inefficient - any feedback would be greatly appreciated.

Code
ReviewSheet Activate
Code: 
Sub worksheet_activate()
'setup reviewSheet, ensure Business Area is selected to allow narrowing of data.
Dim db As DAO.Database
Dim rex As DAO.Recordset
Dim ans As String
On Error GoTo Errorhandler
ActiveSheet.Unprotect "CI"
If ReviewSheet.Range("A1") = "" Then
    'show form to choose business Area
    Business_SelForm.Show
    If Range("A1") = "" Then
        LoadSheet.Activate
        Application.ScreenUpdating = True
        Exit Sub
    Else
    End If
Else
End If
Application.ScreenUpdating = False
ReviewSheet.AutoFilterMode = False
ReviewSheet.Range("A4:R1000").ClearContents 'remove previous copy from rex
'set variables
ans = Range("A1").Value
Set db = OpenDatabase(ActiveWorkbook.Path & "\CI.mdb", False, True, ";PWD=CI")
Set rex = db.OpenRecordset("SELECT TOP 997 * FROM [CI_DATA] WHERE [Business_Area] ='" & ans & "';")
'paste data from database
Range("A4").CopyFromRecordset rex
Range("A4").Select
ActiveWindow.ScrollRow = 1
'kill variables
Set rex = Nothing
Set db = Nothing
'check version then apply version specific criteria
If Application.Version = "11.0" Then
    ActiveSheet.Range("$B$3:$R$1000").AutoFilter Field:=9, Criteria1:="<>Stage 4 - Implemented", Operator:=xlAnd, _
    Criteria2:="<>Stage 5 - Not Proceeding"
Else
    Call AutoFilter2010
End If
 
ActiveSheet.Protect AllowFiltering:=True, Password:="CI"
Application.ScreenUpdating = True
Application.EnableEvents = True
Exit Sub
Errorhandler:
ActiveSheet.Protect AllowFiltering:=True, Password:="CI"
Application.ScreenUpdating = True
Application.EnableEvents = True
'MsgBox ("Database locked"), vbDefaultButton1, "Error"
MsgBox "Error: (" & Err.Number & ") " & Err.Description, vbCritical
End Sub


Double Click to load

Code: 
Private Sub Worksheet_BeforeDoubleClick(ByVal Target As Range, cancel As Boolean)
' allow double click to select IDno
    
Dim db As DAO.Database
Dim IDno As String
Dim rex As DAO.Recordset
On Error GoTo Errorhandler
    
IDno = ActiveCell.Value
Set db = OpenDatabase(ActiveWorkbook.Path & "\CI.mdb", False, True, ";PWD=CI")
Set rex = db.OpenRecordset("SELECT * FROM [CI_DATA] WHERE [IDno] = " & IDno & ";")
      
If rex.EOF Then    'EOF=end of file, meaning no records
  Cells(4, 1).Select
  MsgBox "No data to load for this IDno.", vbDefaultButton1, "Something isn't right"
  Set rex = Nothing
  Set db = Nothing
  Exit Sub
End If
 
UpdateSheet.Range("A1:R1").ClearContents
UpdateSheet.Range("A1").CopyFromRecordset rex
Set db = Nothing
Set rex = Nothing
UpdateSheet.Activate
Exit Sub
Errorhandler:
'MsgBox ("Database locked or wrong column selected!"), vbDefaultButton1, "Something isn't right"
MsgBox "Error: (" & Err.Number & ") " & Err.Description, vbCritical, "Something isn't right"
End Sub

UpdateSheet Activate
Code: 
Sub worksheet_activate()
' open update form
Range("A2").Select
Application.ScreenUpdating = True
UpdateForm.Show
End Sub

UpdateForm - all code

Code: 
Option Explicit
 
 
Private Sub userform_Activate()
Dim DRaised As String
Dim RDate As String
Dim Tdate As Date

On Error GoTo 0
     
'set position to centre of excel window
With UpdateForm
  .StartUpPosition = 0
  .Left = Application.Left + (0.5 * Application.Width) - (0.5 * .Width)
  .Top = Application.Top + (0.5 * Application.Height) - (0.5 * .Height)
End With
     
     
'set variable
Tdate = Date
DRaised = Range("D1").Text
RDate = Range("E1").Text
            
'set box colours where filled is mandatory
Owner.BackColor = &H80FF80
Review_date.BackColor = &H80FF80
BusinessChannel.BackColor = &H80FF80
BusinessArea.BackColor = &H80FF80
Department.BackColor = &H80FF80
Team.BackColor = &H80FF80
Status.BackColor = &H80FF80
Problem.BackColor = &H80FF80
ProcessType.BackColor = &H80FF80
'Me.BackColor = RGB(109, 214, 207)'W&G teal
'reset colours in boxes where required
If Me.Progress = vbNullString Then
    Progress.BackColor = &H80000005
Else
    Progress.BackColor = &H80FF80
End If
If Me.Solution = vbNullString Then
    Solution.BackColor = &H80000005
Else
    Solution.BackColor = &H80FF80
End If
If Me.Benefits = vbNullString Then
    Benefits.BackColor = &H80000005
Else
    Benefits.BackColor = &H80FF80
End If
If Me.Saving = vbNullString Then
    Saving.BackColor = &H80000005
Else
    Saving.BackColor = &H80FF80
End If
If Me.Saving2 = vbNullString Then
    Saving2.BackColor = &H80000005
Else
    Saving2.BackColor = &H80FF80
End If

'set options for fields
With Me.BusinessChannel
    .Clear
    .List = Application.Transpose(Range("BusinessChannel"))
End With
With Me.Status
    .Clear
    .List = Application.Transpose(Range("Stages"))
End With
With Me.ProcessType
    .Clear
    .List = Application.Transpose(Range("ProcessTypes"))
End With
If Me.Status <> "Stage 4 - Implemented" Then
    Me.Saving.Visible = False
    Me.Saving2.Visible = False
Else
    Me.Saving.Visible = True
    Me.Saving2.Visible = True
End If
'toggle savings labels to match whether filled
If Me.Saving.Visible = True Then
    Me.Label26.Visible = False
    Me.Label14.Visible = True
    Me.Label9.Visible = True
Else
    Me.Label26.Visible = True
    Me.Label14.Visible = False
    Me.Label9.Visible = False
End If
On Error Resume Next
'prefill form
UpdateForm.Date_Raised.Text = DRaised
UpdateForm.Review_date.Text = RDate
UpdateForm.BusinessChannel.Text = Range("F1")
UpdateForm.BusinessArea.Text = Range("G1")
UpdateForm.Department.Text = Range("H1")
UpdateForm.Team.Text = Range("I1")
UpdateForm.Status.Text = Range("J1")
UpdateForm.ProcessType.Text = Range("R1")
'prefill captions
UpdateForm.Label10.Caption = "ID # " & UpdateSheet.Range("A1").Value & ""
UpdateForm.Label30.Caption = "Last Updated : " & vbNewLine & UpdateSheet.Range("Q1").Value & ""
Me.Label35.Caption = "Chr left: " & 910 - Len(Me.Problem.Text)
Me.Label37.Caption = "Chr left: " & 910 - Len(Me.Progress.Text)
Me.Label36.Caption = "Chr left: " & 910 - Len(Me.Solution.Text)
Me.Label38.Caption = "Chr left: " & 910 - Len(Me.Benefits.Text)
 
End Sub

********************************
Private Sub BusinessChannel_Change()
Dim strRange As String
Dim rangeCheck As Range
Dim X As Long
On Error Resume Next
If Me.BusinessChannel.ListIndex > -1 Then
    strRange = Me.BusinessChannel
    strRange = Replace(strRange, " ", "")
    X = Len(ThisWorkbook.Names(strRange).Name)
    On Error GoTo 0
    If X <> 0 Then
        Set rangeCheck = Range(strRange)
        With Me.BusinessArea
            .RowSource = vbNullString
            .RowSource = strRange
            .ListIndex = -1
        End With
    Else
    MsgBox "The selected Business Channel, " & strRange & " ," & vbNewLine & _
        "has not been setup!", vbDefaultButton1, "I suggest you contact your Admin"
    Me.BusinessChannel.ListIndex = -1
    End If
Else
    Me.BusinessChannel.ListIndex = -1
End If
End Sub

******************************
Private Sub BusinessArea_Change()
Dim strRange As String
Dim rangeCheck As Range
Dim X As Long
On Error Resume Next
If Me.BusinessArea.ListIndex > -1 Then
    strRange = Me.BusinessArea
    strRange = Replace(strRange, " ", "")
    X = Len(ThisWorkbook.Names(strRange).Name)
    On Error GoTo 0
    If X <> 0 Then
        Set rangeCheck = Range(strRange)
        With Me.Department
            .RowSource = vbNullString
            .RowSource = strRange
            .ListIndex = -1
        End With
    Else
    MsgBox "The selected Business Area, " & strRange & " ," & vbNewLine & _
        "has not been setup!", vbDefaultButton1, "I suggest you contact your Admin"
    Me.BusinessArea.ListIndex = -1
    End If
Else
    Me.BusinessArea.ListIndex = -1
End If
End Sub


**********************************
Private Sub Department_Change()
Dim strRange As String
Dim rangeCheck As Range
Dim X As Long
On Error Resume Next
If Me.Department.ListIndex > -1 Then
    strRange = Me.Department
    strRange = Replace(strRange, " ", "")
    X = Len(ThisWorkbook.Names(strRange).Name)
    On Error GoTo 0
    If X <> 0 Then
        Set rangeCheck = Range(strRange)
        With Me.Team
            .RowSource = vbNullString
            .RowSource = strRange
            .ListIndex = -1
        End With
    Else
    MsgBox "The selected Department, " & strRange & " ," & vbNewLine & _
        "has not been setup!", vbDefaultButton1, "I suggest you contact your Admin"
    Me.Department.ListIndex = -1
    End If
Else
    Me.Department.ListIndex = -1
End If

End Sub

*******************************
Private Sub Status_Change()
'show saving fields when at stage 4
If Me.Status <> "Stage 4 - Implemented" Then
    Me.Saving.Visible = False
    Me.Saving2.Visible = False
Else
    Me.Saving.Visible = True
    Me.Saving2.Visible = True
End If
'show saving labels when at stage 4 and hide instruction label
If Me.Saving.Visible = True Then
    Me.Label26.Visible = False
    Me.Label14.Visible = True
    Me.Label9.Visible = True
Else
    Me.Label26.Visible = True
    Me.Label14.Visible = False
    Me.Label9.Visible = False
End If
End Sub


*******************
Private Sub Review_Date_Exit(ByVal cancel As MSForms.ReturnBoolean)
        If Me.Review_date = vbNullString Then
             Review_date.BackColor = &HFF& ' change the color of the textbox
         cancel = False
     Else
     If Not IsDate(Review_date.Text) Then
         Review_date.BackColor = &HFF& ' change the color of the textbox
         MsgBox "Made up dates make me sad!", vbDefaultButton1, "I am incomplete"
         cancel = False
     Else
          Review_date.BackColor = &H80FF80 ' change color of the textbox
          Review_date.Text = Format(Review_date, "dd/mm/yyyy")
     End If
     End If
End Sub
***************************
Private Sub Owner_Exit(ByVal cancel As MSForms.ReturnBoolean)
    If Me.Owner = vbNullString Then
             Owner.BackColor = &HFF& ' change the color of the textbox
         cancel = False
     Else
 
     
     If IsNumeric(Owner.Text) Or IsDate(Owner.Text) Then
         Owner.BackColor = &HFF& ' change the color of the textbox
         MsgBox "I do not like numbers!", vbDefaultButton1, "I am incomplete"
         cancel = False
     Else
          Owner.BackColor = &H80FF80 ' change color of the textbox
     End If
     End If
End Sub
**************************
Private Sub Problem_Exit(ByVal cancel As MSForms.ReturnBoolean)
    If Me.Problem = vbNullString Then
             Problem.BackColor = &HFF& ' change the color of the textbox
         cancel = False
     Else
          Problem.BackColor = &H80FF80 ' change color of the textbox
     End If
'text remaining
Me.Label35.Caption = "Chr left: " & 910 - Len(Me.Problem.Text)
End Sub

*******************
Private Sub Team_Exit(ByVal cancel As MSForms.ReturnBoolean)
    If Me.Team = vbNullString Then
             Team.BackColor = &HFF& ' change the color of the textbox
         ' setting Cancel to True means the user cannot leave this textbox
         ' until the value is in the proper date format
         cancel = False
        Else
                Team.BackColor = &H80FF80 ' change color of the textbox
         End If
End Sub

********************
Private Sub Department_Exit(ByVal cancel As MSForms.ReturnBoolean)
'=========================================
'|test if textbox contains required data |
'=========================================
If Me.Department = vbNullString Then
     Department.BackColor = &HFF& ' change the color of the textbox
 ' setting Cancel to True means the user cannot leave this textbox
 ' until the value is in the proper date format
 cancel = False
Else
        Department.BackColor = &H80FF80 ' change color of the textbox
 End If
End Sub

*********************
Private Sub BusinessArea_Exit(ByVal cancel As MSForms.ReturnBoolean)
'=========================================
'|test if textbox contains required data |
'=========================================
If Me.BusinessArea = vbNullString Then
    BusinessArea.BackColor = &HFF& ' change the color of the textbox
    cancel = False ' setting Cancel to True means the user cannot leave this textbox
Else
   BusinessArea.BackColor = &H80FF80 ' change color of the textbox
End If
End Sub

**********************
Private Sub Status_Exit(ByVal cancel As MSForms.ReturnBoolean)
'=========================================
'|test if textbox contains required data |
'=========================================
If Me.Status = vbNullString Then
    Status.BackColor = &HFF&
    cancel = False ' setting Cancel to True means the user cannot leave this textbox
Else
    Status.BackColor = &H80FF80
End If
End Sub

*************************
Private Sub ProcessType_Exit(ByVal cancel As MSForms.ReturnBoolean)
'=========================================
'|test if textbox contains required data |
'=========================================
If Me.ProcessType = vbNullString Then
    ProcessType.BackColor = &HFF&
    cancel = False ' setting Cancel to True means the user cannot leave this textbox
Else
    ProcessType.BackColor = &H80FF80
End If
End Sub

**************
Private Sub Saving_Exit(ByVal cancel As MSForms.ReturnBoolean)
'=========================================
'|test if textbox contains required data |
'=========================================
If Me.Saving = vbNullString Then
    Saving.BackColor = &HFF&
ElseIf Not IsNumeric(Saving.Text) Then
    Saving.BackColor = &HFF&
    MsgBox "Feed me numbers!", vbDefaultButton1, "What is the £ value of the saving?"
    cancel = False
Else
    Saving.BackColor = &H80FF80
End If
End Sub

**************
Private Sub Saving2_Exit(ByVal cancel As MSForms.ReturnBoolean)
'=========================================
'|test if textbox contains required data |
'=========================================
If Me.Saving2 = vbNullString Then
    Saving2.BackColor = &HFF&
ElseIf Not IsNumeric(Saving2.Text) Then
    Saving2.BackColor = &HFF&
    MsgBox "Feed me numbers!", vbDefaultButton1, "What is the £ value of the saving?"
    cancel = False
Else
    Saving2.BackColor = &H80FF80
End If
End Sub

**************
Private Sub Solution_Exit(ByVal cancel As MSForms.ReturnBoolean)
'=========================================
'|test if textbox contains required data |
'=========================================
   If Not Me.Solution = vbNullString Then
          Solution.BackColor = &H80FF80
    End If
'text remaining
Me.Label36.Caption = "Chr left: " & 910 - Len(Me.Solution.Text)
End Sub

***************
Private Sub Progress_Exit(ByVal cancel As MSForms.ReturnBoolean)
'=========================================
'|test if textbox contains required data |
'=========================================
If Not Me.Progress = vbNullString Then
   Progress.BackColor = &H80FF80
End If
'text remaining
Me.Label37.Caption = "Chr left: " & 910 - Len(Me.Progress.Text)
End Sub

************
Private Sub Benefits_Exit(ByVal cancel As MSForms.ReturnBoolean)
'=========================================
'|test if textbox contains required data |
'=========================================
If Not Me.Benefits = vbNullString Then
    Benefits.BackColor = &H80FF80
End If
'text remaining
Me.Label38.Caption = "Chr left: " & 910 - Len(Me.Benefits.Text)
End Sub

********************
Private Sub UserForm_QueryClose(cancel As Integer, CloseMode As Integer)
'sub to take control of clicking red x
  
Dim ans As Integer
On Error GoTo 0
If CloseMode = vbFormControlMenu Then ' cancel normal X button behavior
    cancel = True
    'Confirm user wants to close
    ans = MsgBox("Are you sure you want to close?" & vbNewLine & "Remember, nothing will be saved.", vbYesNo, "Leaving so soon?")
    If ans = vbYes Then
        Application.ScreenUpdating = False
        Unload UpdateForm
        'ReviewSheet.Visible = True
        ReviewSheet.Activate
        Application.ScreenUpdating = True
        Exit Sub
    Else
    End If
End If
End Sub

*************************
Private Sub UpdateData_Click()
   
'variables
Dim db As DAO.Database
Dim rex As Recordset
Dim IDno As String
Dim sAns As String
On Error Resume Next
'validate data before Updating to DB
If UpdateForm.Owner = vbNullString Then
    MsgBox "Owner is empty." & vbNewLine & " The data has not been updated.", vbDefaultButton1, "I am incomplete"
    UpdateForm.Owner.BackColor = &HFF&
    Exit Sub
ElseIf Not IsDate(UpdateForm.Review_date) Then
    MsgBox "No date for the date raised." & vbNewLine & " The data has not been updated.", vbDefaultButton1, "I am incomplete"
    UpdateForm.Review_date.BackColor = &HFF&
    Exit Sub
ElseIf UpdateForm.Problem = vbNullString Then
    MsgBox "Problem is empty. " & vbNewLine & "The data has not been updated.", vbDefaultButton1, "I am incomplete"
    UpdateForm.Problem.BackColor = &HFF&
    Exit Sub
ElseIf UpdateForm.BusinessArea = vbNullString Then
    MsgBox "Business Area is empty. " & vbNewLine & "The data has not been updated.", vbDefaultButton1, "I am incomplete"
    UpdateForm.BusinessArea.BackColor = &HFF&
    Exit Sub
ElseIf UpdateForm.Department = vbNullString Then
    MsgBox "Department is empty. " & vbNewLine & "The data has not been updated.", vbDefaultButton1, "I am incomplete"
    UpdateForm.Department.BackColor = &HFF&
    Exit Sub
ElseIf UpdateForm.Team = vbNullString Then
    MsgBox "Team is empty. " & vbNewLine & "The data has not been updated.", vbDefaultButton1, "I am incomplete"
    UpdateForm.Team.BackColor = &HFF&
    Exit Sub
ElseIf UpdateForm.ProcessType = vbNullString Then
    MsgBox "Process Type is empty. " & vbNewLine & "The data has not been updated.", vbDefaultButton1, "I am incomplete"
    UpdateForm.ProcessType.BackColor = &HFF&
    Exit Sub
End If
'move data in to range to allow updates from range
Range("E1") = UpdateForm.Review_date
Range("F1") = UpdateForm.BusinessChannel.Value
Range("G1") = UpdateForm.BusinessArea.Value
Range("H1") = UpdateForm.Department.Value
Range("I1") = UpdateForm.Team.Value
Range("J1") = UpdateForm.Status.Value
Range("Q1") = Date
Range("R1") = UpdateForm.ProcessType
On Error GoTo Errorhandler
IDno = UpdateSheet.Range("A1")
'Set database location
Set db = OpenDatabase(ActiveWorkbook.Path & "\CI.mdb", False, False, ";PWD=CI")
'find correct record
Set rex = db.OpenRecordset("SELECT * FROM CI_DATA WHERE IDno = " & IDno & ";")
'Update entries to database
With rex
    .Edit
        .Fields("Raised_by").Value = Range("B1")
        .Fields("Owner").Value = CleanString(Range("C1"))
        .Fields("Date_Raised").Value = Range("D1")
        .Fields("Review_date").Value = DateValue(Range("E1"))
        .Fields("Business_Channel").Value = Range("F1")
        .Fields("Business_Area").Value = Range("G1")
        .Fields("Department").Value = Range("H1")
        .Fields("Team").Value = Range("I1")
        .Fields("Status").Value = Range("J1")
        .Fields("Problem").Value = CleanString(Range("K1"))
        .Fields("Progress").Value = CleanString(Range("L1"))
        .Fields("Solution").Value = CleanString(Range("M1"))
        .Fields("Benefits").Value = CleanString(Range("N1"))
        .Fields("Saving").Value = Range("O1")
        .Fields("Saving2").Value = Range("P1")
        .Fields("Last_Updated").Value = DateValue(Range("Q1"))
        .Fields("Process_Type").Value = Range("R1")
    .Update
End With
    
'confirm data Updated
MsgBox ("Looks good! Data Updated."), vbDefaultButton1, "Update complete."
               
'Clear fields
UpdateSheet.Range("B1:R1").ClearContents
'reset
Application.ScreenUpdating = False
Unload UpdateForm
ReviewSheet.Activate
ReviewSheet.Unprotect "CI"
sAns = Range("A1").Value
Set rex = db.OpenRecordset("SELECT TOP 997 * FROM [CI_DATA] WHERE [Business_Area] ='" & sAns & "';")
ReviewSheet.AutoFilterMode = False
ReviewSheet.Range("A4:R1000").ClearContents 'remove previous copy from rex
Range("A4").CopyFromRecordset rex 'paste data from database
'check version then apply version specific criteria
If Application.Version = "11.0" Then
    ActiveSheet.Range("$B$3:$R$1000").AutoFilter Field:=9, Criteria1:="<>Stage 4 - Implemented", Operator:=xlAnd, _
    Criteria2:="<>Stage 5 - Not Proceeding"
Else
    Call AutoFilter2010
End If
ReviewSheet.Protect "CI"
Application.ScreenUpdating = True
'kill variables
Set db = Nothing
Set rex = Nothing
Exit Sub
Errorhandler:
MsgBox "Error: (" & Err.Number & ") " & Err.Description, vbCritical, "Something isn't right"
Set rex = Nothing
Set db = Nothing
Unload UpdateForm
LoadSheet.Activate
End Sub

********************
Private Sub Delete_Click()
Dim db As DAO.Database
Dim ARex As DAO.Recordset
Dim DRex As DAO.Recordset
Dim rex As DAO.Recordset
Dim IDno As String
Dim ans As Integer
Dim sAns As String
On Error GoTo Errorhandler
IDno = UpdateSheet.Range("A1")

'confirm data needs to be deleted
ans = MsgBox("Are you sure you want to delete this improvement?" & vbNewLine & vbNewLine & Space(13) & _
        "Remember that not progressing does not mean it needs to be deleted..." & _
         vbNewLine & Space(13) & "and this cannot be undone!", vbYesNo, "Deleting so soon?")
  
If ans = vbYes Then
    MsgBox ("I will now delete this improvement."), vbDefaultButton1, "Time to say goodbye"
    UpdateForm.Hide
ElseIf ans = vbNo Then
    Exit Sub
End If
        
Application.ScreenUpdating = False
'Set database location
Set db = OpenDatabase(ActiveWorkbook.Path & "\CI.mdb", False, False, ";PWD=CI")
Range("E1") = UpdateForm.Review_date
Range("F1") = UpdateForm.BusinessArea.Value
Range("G1") = UpdateForm.Department.Value
Range("H1") = UpdateForm.Team.Value
Range("I1") = UpdateForm.Status.Value
'Update entries to database
Set ARex = db.OpenRecordset("CI_Data_Del")
With ARex
    .AddNew
        .Fields("IDno").Value = Range("A1")
        .Fields("Raised_by").Value = Range("B1")
        .Fields("Owner").Value = CleanString(Range("C1"))
        .Fields("Date_Raised").Value = Range("D1")
        .Fields("Review_Date").Value = Range("E1")
        .Fields("Business_Channel").Value = Range("F1")
        .Fields("Business_Area").Value = Range("G1")
        .Fields("Department").Value = Range("H1")
        .Fields("Team").Value = Range("I1")
        .Fields("Status").Value = Range("J1")
        .Fields("Problem").Value = CleanString(Range("K1"))
        .Fields("Progress").Value = CleanString(Range("L1"))
        .Fields("Solution").Value = CleanString(Range("M1"))
        .Fields("Benefits").Value = CleanString(Range("N1"))
        .Fields("Saving").Value = Range("O1")
        .Fields("Saving2").Value = Range("P1")
        .Fields("Process_Type").Value = Range("R1")
    .Update
End With
Set DRex = db.OpenRecordset("SELECT * FROM CI_DATA WHERE IDno = " & IDno & ";")
DRex.Delete
         
'Clear fields
UpdateSheet.Range("A1:R1").ClearContents
'reset
Unload UpdateForm
ReviewSheet.Activate
ReviewSheet.Unprotect "CI"
sAns = Range("A1").Value
Set rex = db.OpenRecordset("SELECT TOP 997 * FROM [CI_DATA] WHERE [Business_Area] ='" & sAns & "';")
ReviewSheet.AutoFilterMode = False
ReviewSheet.Range("A4:R1000").ClearContents 'remove previous copy from rex
Range("A4").CopyFromRecordset rex 'paste data from database
'check version then apply version specific criteria
If Application.Version = "11.0" Then
    ActiveSheet.Range("$B$3:$R$1000").AutoFilter Field:=9, Criteria1:="<>Stage 4 - Implemented", Operator:=xlAnd, _
    Criteria2:="<>Stage 5 - Not Proceeding"
Else
    Call AutoFilter2010
End If
ReviewSheet.Protect "CI"
'kill variables
Set ARex = Nothing
Set DRex = Nothing
Set db = Nothing
Set rex = Nothing
Exit Sub
Errorhandler:
MsgBox "Error: (" & Err.Number & ") " & Err.Description, vbCritical, "Something isn't right"
Set ARex = Nothing
Set DRex = Nothing
Set db = Nothing
Unload UpdateForm
LoadSheet.Activate
End Sub

********************************
Private Sub Share_Click()
'declare variables
Dim OutMail As Object
Dim OutApp As Object
Dim sProgress As String
Dim sSolution As String
Dim sBenefits As String
Dim lSaving As Long
Dim lSaving2 As Long

'define variables
Set OutApp = CreateObject("Outlook.Application")
Set OutMail = OutApp.CreateItem(0)
'check progress filled
If UpdateForm.Progress.Text = "" Then
    sProgress = "[No current data]"
Else
    sProgress = UpdateForm.Progress.Text
End If
'check solution filled
If UpdateForm.Solution.Text = "" Then
    sSolution = "[No current data]"
Else
    sSolution = UpdateForm.Solution.Text
End If
'check benefits filled
If UpdateForm.Benefits.Text = "" Then
    sBenefits = "[No current data]"
Else
    sBenefits = UpdateForm.Benefits.Text
End If
'check mat savings filled
If UpdateForm.Saving.Text = "" Then
    lSaving = "0"
Else
    lSaving = UpdateForm.Saving.Text
End If
'check mat savings filled
If UpdateForm.Saving2.Text = "" Then
    lSaving2 = "0"
Else
    lSaving2 = UpdateForm.Saving2.Text
End If
'setup email
 With OutMail
            .To = ""
            .CC = ""
            .BCC = ""
            .Subject = "Infinity - Idea number " & Range("A1")
            .Body = "I wanted to share the following idea with you." & vbNewLine & vbNewLine & _
                "Team : " & UpdateForm.Team.Text & vbNewLine & _
                "Owner : " & UpdateForm.Owner.Text & vbNewLine & _
                "Date raised : " & UpdateForm.Date_Raised.Text & vbNewLine & _
                "Opportunity : " & UpdateForm.Problem.Text & vbNewLine & _
                "Progress : " & sProgress & vbNewLine & _
                "Solution : " & sSolution & vbNewLine & _
                "Benefits : " & sBenefits & vbNewLine & _
                "Material savings of £" & lSaving & " and staff savings of £" & lSaving2 & "."
            .display
        
        End With
End Sub


Thank you in advance for any help you can offer.

-Snayff
 

Excel Facts

Links? Where??
If Excel says you have links but you can't find them, go to Formulas, Name Manager. Look for old links to dead workbooks & delete.
Sort by date Sort by votes
I'm not sure if this is the answer, I was having strange intermittent problems with userforms and such also would leave excel crashed (or in some kind of never ending loop) a few months ago, after weeks of scouring the internet I found that .Rowsource was the issue I went through the code and replaced all instances of this with list property and this fixed the problems....Don't know why or how but it works perfectly now. might be wort a try??
i.e
Code: 
Me.ComboBox1.RowSource = [COLOR=#800000]"Shift"
[/COLOR]Me.ComboBox2.RowSource = [COLOR=#800000]"Overview_Reason"[/COLOR][COLOR=#800000]
[/COLOR]
changed to
Code: 
Me.ComboBox1.List = Sheets([COLOR=#800000]"control sheet"[/COLOR]).Range([COLOR=#800000]"Shift"[/COLOR]).Value
Me.ComboBox2.List= Sheets([COLOR=#800000]"control sheet"[/COLOR]).Range([COLOR=#800000]"Overview_Reason"[/COLOR]).Value

Good luck
 
Upvote 0
Thanks Melewie, I'll test it and see how it goes. Intermittent issues are always fun to try and resolve.

For the named range does it need the sheet specified?
 
Upvote 0
Interestingly it seems to have stopped the exit function from working.

Code: 
Private Sub UserForm_QueryClose(cancel As Integer, CloseMode As Integer)
'sub to take control of clicking red x
  
Dim ans As Integer
On Error GoTo 0
If CloseMode = vbFormControlMenu Then ' cancel normal X button behavior
    cancel = True
    'Confirm user wants to close
    ans = MsgBox("Are you sure you want to close?" & vbNewLine & "Remember, nothing will be saved.", vbYesNo, "Leaving so soon?")
    If ans = vbYes Then
        Application.ScreenUpdating = False
        Unload UpdateForm
        'ReviewSheet.Visible = True
        ReviewSheet.Activate
        Application.ScreenUpdating = True
        Exit Sub
    Else
    End If
End If
End Sub
 
Upvote 0
Just in case anyone comes across this in the future, Melewie's suggestion appears to have worked.

As for failing to exit, I just added UpdateForm.Hide to the sub.
 
Upvote 0
I have no idea why rowsource and userforms don't get on, does any smarter person than me on here have any ideas about this?

Not been on here for a couple of days, did you get the exit function working?

----------------------

edit just seen your last post, glad to of helped
 
Upvote 0
Ahhhhhhhhh, turns out it isnt fixed. Just had the same error; userform draws outer border but grey inside, clicking red X then causes userform to be displayed as normal (and triggers expected behaviour on attempting to close). Following that just a constant recalculation. Have to assume I am triggering some sort of loop but cant find it!

Any help would be appreciated.
 
Upvote 0
Hi Melewie, the codes all at the top mate. There isnt anything else thats part of that process, unless you have spotted somethign i havent thoguht of?
 
Upvote 0
You must log in or register to reply here.

Similar threads

D
  • Solved
Error 1004
2
Replies
18
Views
275
dmt32
D
A
  • Solved
Workbook_BeforeClose() is not preventing user to close even when specific ranges are blank
Replies
4
Views
243
John_w
J
J
  • Question Question
Assistance changing VBA code to display as HTML or picture of a selection in Lotus Notes
Replies
2
Views
199
jularobert
J
I
  • Question Question
Advice for slight alteration to existing working code
Replies
1
Views
192
ipbr21054
I
P
  • Question Question
If and ElseIf confusion !
Replies
5
Views
222
Micron
M

Forum statistics

Threads
1,223,214
Messages
6,170,772
Members
452,353
Latest member
strainu

Share this page

We've detected that you are using an adblocker.

We have a great community of people providing Excel help here, but the hosting costs are enormous. You can help keep this site running by allowing ads on MrExcel.com.
Allow Ads at MrExcel

Which adblocker are you using?

Disable AdBlock

Follow these easy steps to disable AdBlock

1)Click on the icon in the browser’s toolbar.
2)Click on the icon in the browser’s toolbar.
2)Click on the "Pause on this site" option.
Go back

Disable AdBlock Plus

Follow these easy steps to disable AdBlock Plus

1)Click on the icon in the browser’s toolbar.
2)Click on the toggle to disable it for "mrexcel.com".
Go back

Disable uBlock Origin

Follow these easy steps to disable uBlock Origin

1)Click on the icon in the browser’s toolbar.
2)Click on the "Power" button.
3)Click on the "Refresh" button.
Go back

Disable uBlock

Follow these easy steps to disable uBlock

1)Click on the icon in the browser’s toolbar.
2)Click on the "Power" button.
3)Click on the "Refresh" button.
Go back
Back
Top