Nearly there - excel query
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?
VB Code:
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