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
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
Target.AddComment Text:=frmFault.cbxFault