Код выполняется только на нескольких записях и пропущенных записях, которые передают правило?

Question

Доброе утро,

У меня есть база данных паспортов безопасности в интересах COSHH, я пытаюсь создать функцию, в которой пользователь может вводить дату в «H7», а любую вводить датыменьше этого значения вся строка будет перенесена в sheet2.

код, который я написал, как показано ниже

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

Проблема, с которой я столкнулся, состоит в том, что этот код принимает определенные строки, но многопропущены строки, даже если они меньше, чем переменная datefrom?

Заранее благодарю за помощь, любые отзывы о написании моего кода приветствуются.

Answer 1

Импортируйте приведенный ниже код в событие изменения листа, на который будет импортирована дата.

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

Лист 1 (включает дату)

Лист 2 (Результаты)

Answer 2

Вам следует избегать использования select, а также лучше ссылаться на свои листы.Что-то вроде приведенного ниже кода должно работать лучше уже:

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