Taking a Log

[DylanJandB]

This is how the worksheet code is atm,

Code: Select all

Private Sub Worksheet_Change(ByVal Target As Range)
    Const strSearchCell = "C1"
    Const SheetName = "CDE Faults"
    Const FaultCol1 = "P"
    Const FaultCol2 = "AB"
    Const DestCol = 32 ' AF
    Dim rngFound As Range
    Dim lngCur As Long
    Dim lngLast As Long
    Dim oldVal As String
    Dim newVal As String
    Dim lUsed As Long
    Dim wsh As Worksheet
    Dim r As Long
    ' Don't do anything if multiple cells have been changed
    If Target.Count > 1 Then Exit Sub
    ' Handle search cell
    If Not Intersect(Range(strSearchCell), Target) Is Nothing Then
        Set rngFound = Cells.Find(What:=Range(strSearchCell).Value, LookAt:=xlPart, After:=Range(strSearchCell))
        If rngFound.Address(False, False) = strSearchCell Then
             MsgBox "The text '" & Range(strSearchCell).Value & "' is not on the board.", vbExclamation
        End If
        rngFound.Select
        Exit Sub
    End If
    Application.EnableEvents = False
    Application.ScreenUpdating = False
    ' Handle columns P:AB
    If Not Intersect(Range(FaultCol1 & "3:" & FaultCol2 & Me.Rows.Count), Target) Is Nothing Then
        newVal = Target.Value
        Application.Undo
        oldVal = Target.Value
        Target.Value = newVal
        If oldVal <> "" And newVal <> "" Then
            lUsed = InStr(oldVal, newVal)
            If lUsed > 0 Then
                If oldVal = newVal Then
                    Target.Value = ""
                ElseIf Right(oldVal, Len(newVal)) = newVal Then
                    Target.Value = Left(oldVal, Len(oldVal) - Len(newVal) - 2)
                Else
                    Target.Value = Replace(oldVal, newVal & ",", "")
                End If
            ElseIf oldVal = "Started" Then
                ' Nothing to do
            ElseIf oldVal = "Start S/H" Then
            ElseIf oldVal = "Stopped" Then
            
            ElseIf oldVal = "Fault" Then
            ElseIf oldVal = "X" Then
            Else
                Target.Value = oldVal & "," & newVal
            End If
        End If
        If Target.Value = "Fault" Then
            Set wsh = Worksheets(SheetName)
            r = wsh.Cells(wsh.Rows.Count, DestCol).End(xlUp).Row + 1
            Target.EntireRow.Copy Destination:=wsh.Range("A" & r)
            wsh.Cells(r, DestCol).Value = Cells(2, Target.Column).Value
            frmFault.Show
            wsh.Cells(r, DestCol + 1).Value = frmFault.cbxFault
            wsh.Cells(r, DestCol + 2).Value = Now
            GoTo ExitHandler
        End If
    End If
    ' Don't do anything if column A has been changed
    If Target.Column = 1 Then GoTo ExitHandler
    ' Handle data entry in columns other than A
    lngCur = Target.Row
    ' *** Start of new code ***
    If Cells(lngCur, 1).Value = "" Then GoTo ExitHandler
    ' *** End of new code *****
    lngLast = lngCur
    ' Find last row with same value in column A
    Do While Cells(lngLast + 1, 1).Value = Cells(lngCur, 1).Value
        lngLast = lngLast + 1
    Loop
    If lngLast > lngCur Then
        ' Copy down
        Target.Copy Destination:=Target.Offset(1, 0).Resize(lngLast - lngCur, 1)
        Application.CutCopyMode = False
    End If

ExitHandler:
    Application.EnableEvents = True
    Application.ScreenUpdating = True
End Sub

This is the code for the frmFault

Code: Select all

Private Sub cmdOK_Click()
    If IsNull(Me.cbxFault) Then
        Me.cbxFault.SetFocus
        MsgBox "Please select a fault!", vbExclamation
    Else
        Me.Hide
    End If
End Sub

I changed txtFault in your code to cbxFault but it returns an error highlighting the line,

Target.AddComment Text:=frmFault.cbxFault

[HansV]

Try changing that line to

Target.AddComment Text:=frmFault.cbxFault.Value

[DylanJandB]

Perfect Hans cheers