Having issues implemented a macro which changes rows to other sheets and an automatic date vba

Question

I have two pieces of code that I am trying to run. I have this macro that I have been running which checks a column for a word, copies that entire row, and paste into the next available row in a sheet that corresponds to the word found, here is the code:

Sub MoveRows()
    Dim ws As Worksheet
    Dim destination As Worksheet
    Dim rng As Range
    Dim r As Long
    
    For Each ws In ThisWorkbook.Worksheets

        'Set the range to search
        Set rng = ws.Range("D:D")

       'Find the rows to move
        For r = rng.Rows.Count To 1 Step -1
            'Check the cell value
            Select Case rng.Cells(r).Value
                Case "Complete"
                    'Set destination worksheet
                    Set destination = ThisWorkbook.Sheets("Completed")
                    If rng.Cells(r).Value = "Complete" And destination.Name <> ws.Name Then
                        'Cut and paste the row
                        rng.Cells(r).EntireRow.Copy destination.Cells(destination.Rows.Count, 1).End(xlUp).Offset(1)

                        'Delete the row
                        rng.Cells(r).EntireRow.Delete
                    End If
                Case "In-Process"
                    'Set destination worksheet
                    Set destination = ThisWorkbook.Sheets("In-Process")
                    If rng.Cells(r).Value = "In-Process" And destination.Name <> ws.Name Then
                        'Cut and paste the row
                        rng.Cells(r).EntireRow.Copy destination.Cells(destination.Rows.Count, 1).End(xlUp).Offset(1)

                        'Delete the row
                        rng.Cells(r).EntireRow.Delete
                    End If
                Case "Waiting on Response"
                    'Set destination worksheet
                    Set destination = ThisWorkbook.Sheets("Waiting on Response")
                    If rng.Cells(r).Value = "Waiting on Response" And destination.Name <> ws.Name Then
                        'Cut and paste the row
                        rng.Cells(r).EntireRow.Copy destination.Cells(destination.Rows.Count, 1).End(xlUp).Offset(1)

                        'Delete the row
                        rng.Cells(r).EntireRow.Delete
                    End If
                  Case "Rerouted"
                    'Set destination worksheet
                    Set destination = ThisWorkbook.Sheets("Rerouted")
                    If rng.Cells(r).Value = "Rerouted" And destination.Name <> ws.Name Then
                        'Cut and paste the row
                        rng.Cells(r).EntireRow.Copy destination.Cells(destination.Rows.Count, 1).End(xlUp).Offset(1)

                        'Delete the row
                        rng.Cells(r).EntireRow.Delete
                    End If
                    
                    
                    
                Case "Draft Complete"
                    'Set the destination worksheet
                    Set destination = ThisWorkbook.Sheets("Draft Complete")
                    If rng.Cells(r).Value = "Draft Complete" And destination.Name <> ws.Name Then
                        'Cut and paste the row
                        rng.Cells(r).EntireRow.Copy destination.Cells(destination.Rows.Count, 1).End(xlUp).Offset(1)

                        'Delete the row
                        rng.Cells(r).EntireRow.Delete
                    End If
                Case "Routed for Approval"
                    'Set the destination worksheet
                    Set destination = ThisWorkbook.Sheets("Routed for Approval")
                    If rng.Cells(r).Value = "Routed for Approval" And destination.Name <> ws.Name Then
                        'Cut and paste the row
                        rng.Cells(r).EntireRow.Copy destination.Cells(destination.Rows.Count, 1).End(xlUp).Offset(1)

                        'Delete the row
                        rng.Cells(r).EntireRow.Delete
                    End If
                Case "Rejected"
                    'Set the destination worksheet
                    Set destination = ThisWorkbook.Sheets("Rejected")
                    If rng.Cells(r).Value = "Rejected" And destination.Name <> ws.Name Then
                        'Cut and paste the row
                        rng.Cells(r).EntireRow.Copy destination.Cells(destination.Rows.Count, 1).End(xlUp).Offset(1)

                        'Delete the row
                        rng.Cells(r).EntireRow.Delete
                                              
                    End If
            End Select
        Next
    Next
End Sub
here

This runs fine until I have this VBA code implemented. Where the idea was to have a time stamp next to the words I typed in a cell. This also works fine by itself. Here is the code:

Private Sub Worksheet_Change(ByVal Target As Range)
    Application.EnableEvents = False
    Dim cell As Range
    Dim rng As Range
    Dim time_stamp As String
    
    Set rng = Range("I2:I100")
    time_stamp = Format(Now, "mm/dd/yyyy hh:mm")
    
    For Each cell In rng
        
        If Not Intersect(Target, cell) Is Nothing Then
            If Len(cell.Value) > 0 Then
                Target.Value = cell.Value & " " & time_stamp
                If Target.Cells.Count = 1 Then 'Check if Target is a single-cell range
                    Target.Characters(Target.Characters.Count - 15, 20).Font.Color = vbRed
                End If
            End If
        End If
        
    Next cell
    Application.EnableEvents = True
End Sub

Here is what happens when I have both implemented:

Also, when I comment out the "Target.Value = cell.Value & " " & time_stamp " line, the macro runs fine.

I tried using variations of If Len(cell.Value), thinking maybe that was the issue. I have also tried to google my issue, but I could never find an answer that was made within the last few years.

Answer 1

A Worksheet Change: Time Stamp With Font Color

Private Sub Worksheet_Change(ByVal Target As Range)
    On Error GoTo ClearError
    
    Dim rg As Range: Set rg = Target.Worksheet.Range("I2:I100")
    Dim trg As Range: Set trg = Intersect(rg, Target)
    If trg Is Nothing Then Exit Sub
    
    Dim TimeStamp As String: TimeStamp = Format(Now, "mm/dd/yyyy hh:mm")
    Dim tsLen As Long: tsLen = Len(TimeStamp)
    
    Application.EnableEvents = False
    
    Dim tCell As Range, tString As String
    
    For Each tCell In trg.Cells
        tString = CStr(tCell.Value)
        If Len(tString) > 0 Then
            tString = tString & " " & TimeStamp
            tCell.Value = tString
            tCell.Font.ColorIndex = xlAutomatic
            tCell.Characters(Len(tString) - tsLen + 1, tsLen).Font.Color = vbRed
        End If
    Next tCell
    
ProcExit:
    On Error Resume Next
        If Not Application.EnableEvents Then Application.EnableEvents = True
    On Error GoTo 0
    Exit Sub
ClearError:
    Debug.Print "Run-time error'" & Err.Number & "':" & vbLf & Err.Description
    Resume ProcExit
End Sub