Press button to assign the reason provided and count

[Paul_Hossler]

See if this floats your boat

Option Explicit




Private Sub Worksheet_Change(ByVal Target As Range)
    Dim r As Range
    Dim iLad As Long
    Dim sLad As String, sReason As String
    
    Set r = Target.Cells(1, 1)
    
    Application.EnableEvents = False
    Select Case r.Address
        Case "$D$8"
            Range("$D$9").Value = Application.Evaluate("=XLOOKUP(D8,PartNum,PartDesc,"""",0,1)")
        Case "$D$9"
            Range("$D$8").Value = Application.Evaluate("=XLOOKUP(D9,PartDesc,PartNum,"""",0,1)")
    
        Case "$H$9", "$J$9"
            sLad = Range("H9").Value
            sReason = Range("J9").Value
            
            'only place I like GoTo's since IMHO is makes the flow easier to follow
            If Len(sLad) = 0 Then GoTo NiceExit
            If Len(sReason) = 0 Then GoTo NiceExit
                
            With wsStats
                
                'empty list, only headers so add as row 2
                If .Cells(1, 1).CurrentRegion.Rows.Count = 1 Then
                    .Cells(2, 1).Value = DateSerial(Year(Now), Month(Now), Day(Now))
                    .Cells(2, 2).Value = sLad
                    .Cells(2, 3).Value = sReason
                    .Cells(2, 4).Value = 1
                    
                    GoTo AllDone
                End If
                
                'first one of the day, any Lad so add at bottom
                iLad = .Cells(1, 1).CurrentRegion.Rows.Count
                If CLng(.Cells(iLad, 1).Value) < CLng(DateSerial(Year(Now), Month(Now), Day(Now))) Then
                    .Cells(iLad + 1, 1).Value = DateSerial(Year(Now), Month(Now), Day(Now))
                    .Cells(iLad + 1, 2).Value = sLad
                    .Cells(iLad + 1, 3).Value = sReason
                    .Cells(iLad + 1, 4).Value = 1
                    
                    GoTo AllDone
                End If
                        
                
                'start at bottom go up looking for Lad and Reason on Today
                iLad = .Cells(1, 1).CurrentRegion.Rows.Count
                
                Do While .Cells(iLad, 1).Value = DateSerial(Year(Now), Month(Now), Day(Now))
                    If .Cells(iLad, 2).Value = sLad And .Cells(iLad, 3).Value = sReason Then
                        .Cells(iLad, 4).Value = .Cells(iLad, 4).Value + 1
                        
                        GoTo AllDone
                    Else
                        iLad = iLad - 1
                        
                        If iLad = 1 Then Exit Do
                    End If
                Loop
                
                'if we got this far, we did not find matching Date, Lad and Reason so add at bottom
                'yes, I know it'sthe same as 'first one of day, but I like the flow
                iLad = .Cells(1, 1).CurrentRegion.Rows.Count
                .Cells(iLad + 1, 1).Value = DateSerial(Year(Now), Month(Now), Day(Now))
                .Cells(iLad + 1, 2).Value = sLad
                .Cells(iLad + 1, 3).Value = sReason
                .Cells(iLad + 1, 4).Value = 1
                    
                GoTo AllDone
            End With
            
AllDone:
            'clear Lad and Reson
            Range("H9").Value = vbNullString
            Range("J9").Value = vbNullString
            
NiceExit:
    End Select
    
    Application.EnableEvents = True
End Sub