Macro not finding finding selected characters in strings

Following code should look at every cell in sheet 1 used range, move any rows where a cell contains one of these four characters: ' or ; or - or ! and delete the blank row in sheet 1.

It's cycling through the cells correctly, but not finding the characters:

Option Explicit
Dim sht As Worksheet, sht2 As Worksheet
Dim a As Long, j As Long, x As Long
Dim sCharOK As String, s As String
Dim r As Range, rc As Range

Sub Characters()

Set sht = Sheet1
Set sht2 = Sheet2

    With sht2
'Find the first free row on the Database containing data and set to memory
    a = sht2.Cells.Find("*", SearchOrder:=xlByRows, searchdirection:=xlPrevious).Row + 1
    If a < 2 Then a = 2
    
sht.Activate

'Set the range to check
Set r = sht.UsedRange

'Set the characters to look for:
sCharOK = " ' ; - !"

'Cycle through the range and move any rows containing the characters to next free row on sheet 2
For Each rc In r
    s = rc.Value
    For j = 1 To Len(s)
    If InStr(s, sCharOK) > 0 Then
        x = ActiveCell.Row
        Rows(ActiveCell.Row).Cut
        sht2.Range("A" & a).Insert
'Reset the next free row and delete empty row in Sheet 1
        a = a + 1
        sht.Rows(x).Delete
        End If
    Next j
    
Next rc

End With

End Sub

Any guidance, suggestions or solutions welcome as ever

Ochimus