Code executing on only a few entries and missing entries that pass the rule? - excel

Question

Good Morning,
I have a database of safety data sheets for the benefit of COSHH, i am trying to create a function in which the user can enter a date into "H7" and any entried with dates less than that one will have the entire row transferred into sheet2.
the code i have written is as below
Sub checkdatasheets()
Dim datefrom As Variant
'select first entry
Sheet1.Range("E2").Select
'continue until an empty cell is reached
Do Until ActiveCell.Offset(1, 0).Value = ""
If ActiveCell.Value = "" Then GoTo skipto:
'aquire date parameter
datefrom = Sheet1.Range("H7")
'if revision date is less than the date parameter copy and add to sheet2
If ActiveCell.Value <= datefrom Then
ActiveCell.Rows.EntireRow.Copy
Sheets("Sheet2").Select
NextRow = Cells(Rows.Count, 1).End(xlUp).Row + 1
Cells(NextRow, 1).Select
ActiveSheet.Paste
Sheets("Sheet1").Select
End If
'move onto next cell
ActiveCell.Offset(1, 0).Select
Loop
skipto: MsgBox "Missing Data Sheet"
End Sub
The issue i am having is that this code takes certain rows but lots of rows are missed, even though they are less than the datefrom variable?
Thank you in advance for your help, any feedback on the writing of my code would be appreciated.

Answer 1

You should avoid using select and also reference your sheets better. Something like code below should work better allready:
Sub checkdatasheets2()
For X = 2 To Sheets(1).Cells(Rows.Count, 5).End(xlUp).Row
If Sheets(1).Cells(X, 5).Value < Sheets(1).Cells(7, 8).Value Then
Sheets(1).Rows(X).Copy Destination:=Sheets(2).Range("A" & Sheets(2).Cells(Sheets(2).Rows.Count, 5).End(xlUp).Row + 1)
End If
Next X
End Sub

Answer 2

Import the below code in the change event of the sheet which you will import the date.
Private Sub Worksheet_Change(ByVal Target As Range)
Dim sDate As Date
Dim LastRow1 As Long, LastRow2 As Long, i As Long
If Not Intersect(Target, Range("A1")) Is Nothing Then
If IsDate(Target.Value) Then
sDate = CDate(Target.Value)
LastRow1 = Sheet1.Cells(Sheet1.Rows.Count, "A").End(xlUp).Row
For i = 3 To LastRow1
If CDate(Sheet1.Range("A" & i).Value) < sDate Then
LastRow2 = Sheet2.Cells(Sheet2.Rows.Count, "A").End(xlUp).Row
Sheet1.Rows(i).Copy Sheet2.Rows(LastRow2 + 1)
End If
Next i
Else
MsgBox "Please insert a valid date."
End If
End If
End Sub
Sheet 1 (includes the date)
Sheet 2 (Results)