VBA find and move a cell with exact word - more complex than the title suggests

Question

I promise I have searched for this answer before coming here to ask;

I'm trying to create a VBA to search column J for the word "To". If it is found it needs to move the cell to column L.

What I am struggling with is that it only needs to move if "To" is on its own. I have cells that contain, for example, "To Sarah" but these need to stay in its place.

Can anyone suggest a workaround? Many thanks Pip

Answer 1

See the comments in the code for explanation.

Option Explicit

Public Sub Example()
    ' define worksheet
    Dim ws As Worksheet
    Set ws = ThisWorkbook.Worksheets("Sheet1")
    
    ' find last used row in column J
    Dim LastRow As Long
    LastRow = ws.Cells(ws.Rows.Count, "J").End(xlUp).Row
    
    ' collect all cells with "To" in this variable
    Dim FoundCells As Range
    
    Dim iRow As Long
    For iRow = 1 To LastRow  ' loop through cells in J
        If ws.Cells(iRow, "J").Value = "To" Then  ' check if the cell is "To"
            ' if yes add the cell to FoundCells
            If FoundCells Is Nothing Then  ' first cell found
                Set FoundCells = ws.Cells(iRow, "J")
            Else  ' all other cells found
                Set FoundCells = Union(FoundCells, ws.Cells(iRow, "J"))
            End If
        End If
    Next iRow
    
    If Not FoundCells Is Nothing Then
        ' copy found "To" values 2 columns to the right
        FoundCells.Offset(ColumnOffset:=2).Value = FoundCells.Value
    
        ' delete found "To" vaules (from column J)
        FoundCells.Clear
    Else
        MsgBox "No cells with ""To"" were found."
    End If
End Sub

We loop through all used cells in column J, check each cell if it is To and if so collect the cell in FoundCells. In the end we copy the To values from those cells 2 columns to the right and delete the To values in the found cells.