VBA to copy row from worksheet and paste it into a different worksheet if criteria is met

Question

I am currently trying to copy data from a worksheet into another If the dates in the columns F or G or H from the sheet "QJ Portfolio" are between the dates in the Cells B1 and D1 of the sheet "Archive". To do so, I am using this code seen here 1 slightly modified. The problem is that it's just copying every row and I can't understand why.

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

This is the problem with taking code you don't understand and just adding your criteria to it. The If `.Cells(i, 6).Value >= DFrom & .Cells(i, 6).Value <= DTo` doesn't return the value you want `F8` through the script and work out what's going on — Badja, Mar 05 '19 at 13:13
You need the logical `And` instead of the ampersand `&` in your `If...End If`. — BigBen, Mar 05 '19 at 13:14

score 0 · Accepted Answer · answered Mar 05 '19 at 13:33

It looks like you've confused your If then statement. Try the following.

    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

VBA to copy row from worksheet and paste it into a different worksheet if criteria is met

1 Answers1