VBA, чтобы скопировать строку из листа и вставить ее в другой лист, если критерии удовлетворены

Question

В настоящее время я пытаюсь скопировать данные из рабочей таблицы в другую, если даты в столбцах F или G или H из листа «Портфолио QJ» находятся между датами в ячейках B1 и D1 листа «Архив».Для этого я использую этот код 1 , слегка измененный.Проблема в том, что он просто копирует каждую строку, и я не могу понять, почему.

Sub Archive()
   Dim LastRow As Long
   Dim i As Long, j As Long
   Dim DFrom As Date
   Dim DTo As Date

   DFrom = Worksheets("Archive").Cells(1, 2).Value
   DTo = Worksheets("Archive").Cells(1, 4).Value

   'Find the last used row in a Column: column A in this example
   With Worksheets("QJ Portfolio")
      LastRow = .Cells(.Rows.Count, "A").End(xlUp).Row
   End With

   MsgBox (LastRow)
   'first row number where you need to paste values in Sheet1'
   With Worksheets("Archive")
      j = .Cells(.Rows.Count, "A").End(xlUp).Row + 1
   End With

   For i = 1 To LastRow
       With Worksheets("QJ Portfolio")
           If .Cells(i, 6).Value >= DFrom & .Cells(i, 6).Value <= DTo Or         
.Cells(i, 7).Value >= DFrom & .Cells(i, 7).Value <= DTo Or .Cells(i, 8).Value >= DFrom & .Cells(i, 8).Value <= DTo Then
               .Rows(i).Copy Destination:=Worksheets("Archive").Range("A" & j)
               j = j + 1

           End If
       End With
   Next i
End Sub

Answer 1

Похоже, вы запутали свое утверждение If then. Попробуйте следующее.

    Sub Archive()
Dim LastRow As Long
Dim i As Long, j As Long
Dim DFrom As Date
Dim DTo As Date

DFrom = Worksheets("Archive").Cells(1, 2).Value
DTo = Worksheets("Archive").Cells(1, 4).Value

'Find the last used row in a Column: column A in this example
With Worksheets("QJ Portfolio")
 LastRow = .Cells(.Rows.Count, "A").End(xlUp).Row
End With

MsgBox (LastRow)
'first row number where you need to paste values in Sheet1'
With Worksheets("Archive")
  j = .Cells(.Rows.Count, "A").End(xlUp).Row + 1
End With

For i = 1 To LastRow
   With Worksheets("QJ Portfolio")
       If (.Cells(i, 6).Value >= DFrom And .Cells(i, 6).Value <= DTo) And (.Cells(i, 7).Value >= DFrom And .Cells(i, 7).Value <= DTo) And (.Cells(i, 8).Value >= DFrom And .Cells(i, 8).Value <= DTo) Then
           .Rows(i).Copy Destination:=Worksheets("Archive").Range("A" & j)
           j = j + 1

       End If
   End With
Next i
End Sub