Hi OldJay,

'--------------------
I didn't tell you every thing
The list in Sheet 1 starts at row B20
The list on sheet Verify starts B9
I want to move them not copy to the bottom of the existing list
'--------------------

Try the following version:

'============
Public Sub CopyRange()
Dim WB As Workbook
Dim SH As Worksheet
Dim destSH As Worksheet
Dim destRng As Range
Dim rng As Range
Dim copyRng As Range
Dim rCell As Range
Dim LRow As Long
Dim iRow As Long
Dim CalcMode As Long
Const sStr = "X"

Set WB = Workbooks("MyBook.xls") '<<==== CHANGE

With WB
Set SH = .Sheets("Sheet1")
Set destSH = .Sheets("Verified")
End With

With destSH
iRow = .Range("B" & .Rows.Count).End(xlUp).Row
If iRow < 9 Then
iRow = 8
End If

Set destRng = .Range("B" & iRow + 1)
End With

With SH
LRow = .Cells(Rows.Count, "A").End(xlUp).Row
Set rng = .Range("A1:A" & LRow)
End With

On Error GoTo XIT
With Application
CalcMode = .Calculation
.Calculation = xlCalculationManual
.ScreenUpdating = False
End With

For Each rCell In rng.Cells
If InStr(1, rCell, sStr, vbTextCompare) 0 Then
If copyRng Is Nothing Then
Set copyRng = rCell.Offset(0, 1).Resize(1, 4)
Else
Set copyRng = _
Union(rCell.Offset(0, 1).Resize(1, 4), copyRng)
End If
End If
Next rCell

If Not copyRng Is Nothing Then
With copyRng
.Copy Destination:=destRng
.EntireRow.Delete
End With
End If

XIT:
With Application
.Calculation = CalcMode
.ScreenUpdating = True
End With
End Sub
'<<============


---
Regards,
Norman