Macro stops because of blank cells

I have a great little macro to find and sort individual part names from a list on one sheet and place it in a second, where I then do a count and other bits and pieces. The problem I'm having is that the first list could have gaps in the row and if thats the case the macro stops there, I need to to look at at least the next 10 row to make sure it has reached the end of the list.

can anyone help?

Mark

Private Sub CommandButton1_Click()
Dim sIn As Worksheet
Dim sOut As Worksheet
Dim rIn As Integer
Dim cIn As Integer
Dim rOut As Integer
Dim cOut As Integer
Dim Num As Integer
Dim NewValue
Dim Found As Boolean
Dim SearchRange As Range

'set the two worksheets
Set sIn = Sheets("Valve Schedule")
Set sOut = Sheets("Totals")

'start input from F19
rIn = 7

cIn = 7

'start output from A10
rOut = 24
cOut = 1
Num = 0

'clear ouput range
Range(sOut.Cells(rOut, cOut), sOut.Cells(rOut + 1000, cOut)).ClearContents

'this is needed for the Match function which returns an error if not found
On Error Resume Next

'run through input list
Do While sIn.Cells(rIn, cIn).Value <> ""
NewValue = sIn.Cells(rIn, cIn).Value

'try to find the item in the output list
Set SearchRange = Range(sOut.Cells(rOut, cOut), sOut.Cells(rOut + Num, cOut))

Found = False
Found = IsNumeric(Application.WorksheetFunction.Match(NewValue, SearchRange, 0))

'add item to destination
If Not Found Then
sOut.Cells(rOut + Num, cOut).Value = NewValue
Num = Num + 1
End If

rIn = rIn + 1
Loop

On Error GoTo 0

MsgBox "Completed processing. Unique items written:" + Str(Num)

' Sub SORT()
'
' SORT Macro
'
'
Range("A24:A252").Select
ActiveWorkbook.Worksheets("Totals").Sort.SortFields.Clear
ActiveWorkbook.Worksheets("Totals").Sort.SortFields.Add Key:=Range("A24:A42") _
, SortOn:=xlSortOnValues, Order:=xlAscending, DataOption:=xlSortNormal
With ActiveWorkbook.Worksheets("Totals").Sort
.SetRange Range("A24:A42")
.Header = xlGuess
.MatchCase = False
.Orientation = xlTopToBottom
.SortMethod = xlPinYin
.Apply
End With
End Sub