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

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.

CodePudding user response：

You're triggering your event handler from MoveRows - you can disable events to prevent that:

Sub MoveRows()
    Dim ws As Worksheet, destination As Worksheet, rng As Range, r As Long, c As Range
    Dim destName As String, v
    For Each ws In ThisWorkbook.Worksheets
        
        'Set the range to search
        Set rng = ws.Range("D1:D" & ws.Cells(Rows.Count, "D").End(xlUp))

        On Error GoTo haveError
        Application.EnableEvents = False '<<<<   disable events
        
        'Find the rows to move
        For r = rng.Rows.Count To 1 Step -1
            Set c = rng.Cells(r)
            v = c.Value
            
            Select Case v
                Case "Complete": destName = "Completed" 'different sheet name from cell value
                Case "In-Process", "Waiting on Response", "Rerouted", _
                      "Draft Complete", "Routed for Approval", "Rejected"
                    destName = v  'same sheet name as cell value
                Case Else: destName = ""
            End Select
                
            If Len(destName) > 0 Then         'got a destination sheet?
                If destName <> ws.Name Then   'not the same sheet?
                    c.EntireRow.Copy _
                      ThisWorkbook.Sheets(destName).Cells(Rows.Count, 1).End(xlUp).Offset(1)
                    c.EntireRow.Delete
                End If
            End If
        Next r
    Next ws

haveError:
    If Err.Number > 0 Then MsgBox Err.Description
    'ensure events are re-enabled
    Application.EnableEvents = True
End Sub

CodePudding user response：

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