Excelで特定の文字列を含むセルを右に1・上に1セル移動させたいです

VBAで以下のように構成してみました。
試してみてください。

Option Explicit
Sub 特定文字列をセル移動()
    '  A列の各セルが文字列"1111"を含むセルを対象として、
    '  右に1・上に1セル移動する。
    '
    Dim wkLastRow
    Dim wkCnt
    Dim refCell As Range
    ' 有効な最終行を求める
    wkLastRow = Cells.SpecialCells(xlCellTypeLastCell).Row
    
    wkCnt = 0
    ' A列の先頭から最終行のセルまでを対象として逐次処理する
    For Each refCell In Range(Cells(1, 1), Cells(wkLastRow, 1))
       'If Left(refcell, 4) = "1111" Then  ' "1111" で始まる文字列のとき
        If InStr(refCell, "1111") > 0 Then ' "1111"を含む場合
            wkCnt = wkCnt + 1
            Debug.Print wkCnt, refCell.Address, refCell
            refCell.Cut refCell.Offset(-1, 1) 'セルを移動する
        End If
        DoEvents
    Next
    MsgBox "処理終了！  処理数：" & wkCnt
End Sub