Taking a Log

[DylanJandB]

Basically what I want to do is that, when I pick the option "Fault" from a drop down list in the ranges:

P:AB in sheets "Front Board"
L:Z in sheet "McCloskeys"
I:R in sheet "Tesab"

That the row is logged on a sheet called "Faults" for "Front Board", "McCloskeys Faults" and then "Tesab Faults"

When you select fault a box would pop up, asking what the fault is where I would then select from a drop down list a particular fault.. This data selected from the pop up box is added onto the next column of the row the fault is to do with in the Faults sheet.

Also would like to add a date stamp to the row so I could refer to what day the fault occurred.

Any help would be appreciated. Thanks

[Rudi]

Would it be possible to provide a desensitized sample workbook that contains your current sheet structures so it would be easier for us to create the functionality that you need.

[HansV]

Create a userform with a combo box cbxFaults and a command button cmdOK.
Either set the RowSource of the combo box to a range that lists the fault types, or populate it in the Userform_Initialize event.

Here is sample code:

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

Private Sub UserForm_Initialize()
    With Me.cbxFault
        .AddItem "My Fault"
        .AddItem "Your Fault"
        .AddItem "Other Fault"
    End With
End Sub

Next, create a Worksheet_Change event for the Front Board sheet, or add code to it if it already exists:

Code: Select all

Private Sub Worksheet_Change(ByVal Target As Range)
    Const SheetName = "Faults"
    Const FaultCols = "P:AB"
    Dim cel As Range
    Dim wsh As Worksheet
    Dim r As Long
    If Not Intersect(Range(FaultCols), Target) Is Nothing Then
        Set wsh = Worksheets(SheetName)
        r = wsh.Range("A" & wsh.Rows.Count).End(xlUp).Row
        Application.EnableEvents = False
        For Each cel In Intersect(Range(FaultCols), Target)
            If cel.Value = "Fault" Then
                r = r + 1
                wsh.Range("A" & r).Value = cel.Address
                frmFault.Show
                wsh.Range("B" & r).Value = frmFault.cbxFault
                wsh.Range("C" & r).Value = Now
            End If
        Next cel
        Application.EnableEvents = True
    End If
End Sub

For the McCloskeys and Tesab sheets you need to create the same Worksheet_Change event procedure, and modify the SheetName and FaultCols constants at the beginning.

[HansV]

Here is a sample workbook (for some reason, I couldn't attach it to my previous reply).

FaultLog.xlsm

[Rudi]

Would it be possible to provide a desensitized sample workbook that contains your current sheet structures so it would be easier for us to create the functionality that you need.

.....or just follow Hans's instructions.....

[Rudi]

Here is a sample workbook (for some reason, I couldn't attach it to my previous reply).

FaultLog.xlsm

Sorry Hans...you don't have enough admin rights to do that!!

[HansV]

I had to close and restart my browser, then I could upload again...

[DylanJandB]

Hans, Thats close to what I want, but I need to know what job the fault is for, which is why I need it also to log the whole row, and then add on exactly what you already have produced to the end of that row? For example, theres a fault on Row 3 of Front Board,

The fault sheet would show that WHOLE row and then add on exactly what you already have. Also under the first column of your Faults sheet, it is just showing "$V$13" and not the actual complete cell.

Will this pop up box show if the cell value is "Started, Fault"? If so, could you make it show if the cell contains "Fault".

Thanks Hans!

[HansV]

That was not clear at all from your original post...

What is the last column used in the Front Board, McCloskeys and Tesab sheets?

[DylanJandB]

Haha sorry,

I'll give a bit more information.The last column used on each of those sheets is AE.

I thought it would be easier for you to just copy the whole row into the faults sheets and then I would hide the column I don't need.
What I want shown on the Fault sheet is:

Job Reference | Drawing Number | Revision | Description| Quantity | Cell | Type of Fault |Time of Fault

McCloskeys Fault sheet:

Serial Advice No | Description | Quantity | Cell | Type of Fault | Time of Fault

Tesab Faults:

Reference | Description | Quantity | Cell | Type of Fault | Time of Fault


In the column "Cell" (the one you created) should be the title of the column that the fault occurred in. E.g. Materials, Painted etc. This is in row 2 of the column that the fault occurred. Everything else should be just as you created in the first version!

Thanks

[HansV]

Try this version of the Worksheet_Change event procedure for Front Board:

Code: Select all

Private Sub Worksheet_Change(ByVal Target As Range)
    Const SheetName = "Faults"
    Const FaultCols = "P:AB"
    Dim cel As Range
    Dim wsh As Worksheet
    Dim r As Long
    If Not Intersect(Range(FaultCols), Target) Is Nothing Then
        Set wsh = Worksheets(SheetName)
        r = wsh.Range("A" & wsh.Rows.Count).End(xlUp).Row
        Application.EnableEvents = False
        For Each cel In Intersect(Range(FaultCols), Target)
            If cel.Value = "Fault" Then
                r = r + 1
                cel.EntireRow.Copy Destination:=wsh.Range("A" & r)
                wsh.Range("AF" & r).Value = Cells(2, cel.Column).Value
                frmFault.Show
                wsh.Range("AG" & r).Value = frmFault.cbxFault
                wsh.Range("AH" & r).Value = Now
            End If
        Next cel
        Application.EnableEvents = True
    End If
End Sub

[DylanJandB]

Hans, everything is working perfectly just like I wanted.

Just want to change one thing, and that's the combo box. I want to change it to something I can type into and then it logs what I type instead of a combo box. Gives me way more leeway on what type of fault to assign it?

Thanks!

[HansV]

Just replace the combo box with a text box.

A slightly improved version of the macro that makes it easier if you want to copy the extra information (cell, type and time) starting at another column than AF - you'll only need to change the constant DestCol.

Code: Select all

Private Sub Worksheet_Change(ByVal Target As Range)
    Const SheetName = "Faults"
    Const FaultCols = "P:AB"
    Const DestCol = 32 ' AF
    Dim cel As Range
    Dim wsh As Worksheet
    Dim r As Long
    If Not Intersect(Range(FaultCols), Target) Is Nothing Then
        Set wsh = Worksheets(SheetName)
        r = wsh.Cells(wsh.Rows.Count, DestCol).End(xlUp).Row
        Application.EnableEvents = False
        For Each cel In Intersect(Range(FaultCols), Target)
            If cel.Value = "Fault" Then
                r = r + 1
                cel.EntireRow.Copy Destination:=wsh.Range("A" & r)
                wsh.Cells(r, DestCol).Value = Cells(2, cel.Column).Value
                frmFault.Show
                wsh.Cells(r, DestCol + 1).Value = frmFault.cbxFault
                wsh.Cells(r, DestCol + 2).Value = Now
            End If
        Next cel
        Application.EnableEvents = True
    End If
End Sub

[DylanJandB]

Thanks Hans, more than perfect.

[DylanJandB]

Hans, previously you supplied me with a worksheet change event that if you enter some data in columns P:AB, and the value in column A is the same, it copies the data down until it comes to a different value in column A.

Is there anyway I can keep this happening but if "Fault" is entered, it doesn't copy it down and just keeps it on the line it was entered?

Here is "Front Board" worksheet code.. Can you tell me what to change so I can apply it to McCloskeys and Tesab aswell?

Code: Select all

Private Sub Worksheet_Change(ByVal Target As Range)
    Const strSearchCell = "C1"
    Const SheetName = "CDE Faults"
    Const FaultCols = "P:AB"
    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 rData As Range, rData2 As Range, rC As Range
    Dim sCode As String, sCode2 As String
    Dim cel As Range
    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
    ' Handle columns P:AB
    If Not Intersect(Range("P3:AB" & Me.Rows.Count), Target) Is Nothing Then
        Application.EnableEvents = False
        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
            Else
                Target.Value = oldVal & "," & newVal
            End If
        End If
        Application.EnableEvents = True
    End If
    ' Don't do anything if column A has been changed
    If Target.Column = 1 Then Exit Sub
    ' Handle data entry in columns other than A
    lngCur = Target.Row
    ' *** Start of new code ***
    If Cells(lngCur, 1).Value = "" Then Exit Sub
    ' *** 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
        Application.ScreenUpdating = False
        Application.EnableEvents = False
        Target.Copy Destination:=Target.Offset(1, 0).Resize(lngLast - lngCur, 1)
        Application.CutCopyMode = False
        Application.EnableEvents = True
        Application.ScreenUpdating = True
    End If



    Application.ScreenUpdating = False
    Application.EnableEvents = False
    Set rData = Range("P3", Range("P" & Rows.Count).End(xlUp))
    Set rData2 = Range("Q3", Range("Q" & Rows.Count).End(xlUp))
    sCode = Target.Offset(0, -1).Value
    sCode2 = Target.Offset(0, -2).Value
    If Not Intersect(rData, Target) Is Nothing Then
        For Each rC In rData
            If rC.Offset(0, -1).Value = sCode Then
                rC.Value = Target.Value
            End If
        Next rC
    End If
    If Not Intersect(rData2, Target) Is Nothing Then
        For Each rC In rData2
            If rC.Offset(0, -2).Value = sCode2 Then
                rC.Value = Target.Value
            End If
        Next rC
    End If
    Application.EnableEvents = True
    Application.ScreenUpdating = True
    



    If Not Intersect(Range(FaultCols), Target) Is Nothing Then
        Set wsh = Worksheets(SheetName)
        r = wsh.Range("A" & wsh.Rows.Count).End(xlUp).Row
        Application.EnableEvents = False
        For Each cel In Intersect(Range(FaultCols), Target)
            If cel.Value = "Fault" Then
                r = r + 1
                cel.EntireRow.Copy Destination:=wsh.Range("A" & r)
                wsh.Range("AF" & r).Value = Cells(2, cel.Column).Value
                frmFault.Show
                wsh.Range("AG" & r).Value = frmFault.cbxFault
                wsh.Range("AH" & r).Value = Now
            End If
        Next cel
        Application.EnableEvents = True
    End If
End Sub

Thanks!

[HansV]

It's getting hard to keep track of everything the code is doing, but try this modified version. You can modify the constants at the beginning for the other sheets.

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 rData As Range, rData2 As Range, rC As Range
    Dim sCode As String, sCode2 As String
    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
            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.txtFault
            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

    Set rData = Range("P3", Range("P" & Rows.Count).End(xlUp))
    Set rData2 = Range("Q3", Range("Q" & Rows.Count).End(xlUp))
    sCode = Target.Offset(0, -1).Value
    sCode2 = Target.Offset(0, -2).Value
    If Not Intersect(rData, Target) Is Nothing Then
        For Each rC In rData
            If rC.Offset(0, -1).Value = sCode Then
                rC.Value = Target.Value
            End If
        Next rC
    End If
    If Not Intersect(rData2, Target) Is Nothing Then
        For Each rC In rData2
            If rC.Offset(0, -2).Value = sCode2 Then
                rC.Value = Target.Value
            End If
        Next rC
    End If

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

[DylanJandB]

Grave dig,

But the question is to do with this exact code.

Hans, is there anyway you could modify this so that when I type into the box what the type of fault is, it also adds a comment onto the cell with "Fault" in it, so all i have to do is hover over the cell to see the type of fault? And then once fault is removed from that cell, the comment removed with it?

[HansV]

Does this do what you want? It's just a guess, not having the workbook in front of me.

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 rData As Range, rData2 As Range, rC As Range
    Dim sCode As String, sCode2 As String
    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
            Else
                Target.Value = oldVal & "," & newVal
            End If
        End If
        On Error Resume Next
        Target.Comment.Delete
        On Error GoTo 0
        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.txtFault
            wsh.Cells(r, DestCol + 2).Value = Now
            Target.AddComment Text:=frmFault.txtFault
            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

    Set rData = Range("P3", Range("P" & Rows.Count).End(xlUp))
    Set rData2 = Range("Q3", Range("Q" & Rows.Count).End(xlUp))
    sCode = Target.Offset(0, -1).Value
    sCode2 = Target.Offset(0, -2).Value
    If Not Intersect(rData, Target) Is Nothing Then
        For Each rC In rData
            If rC.Offset(0, -1).Value = sCode Then
                rC.Value = Target.Value
            End If
        Next rC
    End If
    If Not Intersect(rData2, Target) Is Nothing Then
        For Each rC In rData2
            If rC.Offset(0, -2).Value = sCode2 Then
                rC.Value = Target.Value
            End If
        Next rC
    End If

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

[DylanJandB]

Compile Error:
Method or data member not found

Highlighting ".txtFault" on line wsh.Cells(r, DestCol + 1).Value = frmFault.txtFault

[HansV]

I simply copied the code from my previous reply. If you have changed that in the intervening month, you must change the new code accordingly. I assumed you had a userform frmFault with a text box txtFault.