Nearly there - excel query

[gilly]

I have a program below which nearly works. One small problem. The program is designed to read through an excel spreadsheet and extract ONLY the sections where delivery date = "00/00/0000".

PROBLEM:- The program currently extracts the first record and the last record, it misses out the records in the middle.

eg. my excel spreadsheet has 4 records with a delivery date = 00/00/0000. The program extracts the first and last records where delivery date = 00/00/0000. Why does it miss the ones in the middle?

Any ideas?

Option Explicit
Dim objExcel As Object 'instead of Excel.Application
Dim oXLApp As Object  'instead of Excel.Spreadsheet
Dim NotShippedRow As Integer
Dim CurrentCell As Range
 
Private Sub Command1_Click()
objExcel.Worksheets("Sheet1").Select
objExcel.Range("H1").Select
Do Until objExcel.ActiveCell.Row = 800 'Can set this to any row number you like
If objExcel.ActiveCell.Value = "00/00/0000" Then 'each time a 00/00/0000 is found copy it
NotShippedRow = objExcel.ActiveCell.Row - 3
Call CopyCells
End If
 
objExcel.ActiveCell.Offset(1, 0).Select
Loop
 
 
End Sub
 
Sub CopyCells()
Dim MyRange As Object
Set MyRange = objExcel.Worksheets("Sheet1").Range(objExcel.Cells(NotShippedRow, 1), objExcel.Cells(NotShippedRow + 10, 9))
 
MyRange.Select
Selection.Copy
objExcel.Worksheets("Sheet2").Select
objExcel.Range("A1").Select
If objExcel.ActiveCell = "" Then
objExcel.ActiveSheet.Paste
objExcel.Worksheets("Sheet1").Select
objExcel.Cells(NotShippedRow + 4, 8).Select
Else
objExcel.ActiveCell.Offset(13, 0).Select 'If one 00/00/0000 has been pasted move down 13 lines and paste the next
objExcel.ActiveSheet.Paste
objExcel.Worksheets("Sheet1").Select
objExcel.Cells(NotShippedRow + 4, 8).Select
End If
 'objExcel.Quit
   'Set objExcel = Nothing
End Sub
 
Private Sub Form_Load()
Set objExcel = CreateObject("Excel.Application")
Set oXLApp = objExcel.Workbooks.Open(FileName:=App.Path & "\" & "New.xls")
objExcel.Visible = True 'show excel or not
 
 
End Sub

nearly