Dim rng as Range
Dim i as Long, k as Long
Dim Last_Row as Long
Dim WB1 as String
Dim WS as String
Dim Monthly_Report as String
WB1 = "????"
WS = "????"
Monthly_Report = "?????"
Last_Row = Workbooks(WB1).Worksheets(1) _
.Cells(rows.count,1).End(xlup).Row
k = Workbooks(Montly_Report) _
.Worksheets(WS).Cells(rows.count,1) _
.End(xlup).Row
For i = 1 To Last_Row
With Workbooks(WB1).Worksheets(1)
if .Cells(i,Exp_Date_Column) = Date_Report Then
if rng is nothing then
set rng = .Cells(i,1)
else
set rng = union(rng,.cells(i,1))
end if
End If
End with
Next i
if not rng is nothing then
rng.EntireRow.copy Destination:=
Workbooks(Montly_Report).Worksheets(WS) _
.Cells(k,1)
rng.EntireRow.Delete
End if

Another way would be to apply an autofilter to your data, filtering on the
date of interest. If that isn't fast enough, post back and I will put up
the autofilter method.

--
Regards,
Tom Ogilvy



"Valeria" wrote in message
...
Dear experts,
I have a macro that simply compares dates in 2 databases, and if the dates
are the same, then it cuts the row from the first database and copies it
to
the second workbook.
The macro works very quickly at the beginning, but it gets very slow as it
runs (it takes hours to go thorugh 400 rows)!
Is there a way to modify the code to have it working more efficiently?
Many thanks!
Best regards,
Valeria

For i = 1 To Last_Row

If Workbooks(WB1).Worksheets(1).Cells(i, Exp_Date_Column) =
Date_Report
Then
Workbooks(WB1).Worksheets(1).Rows(i).Cut
Workbooks(Montly_Report).Worksheets(WS).Rows(k)
Workbooks(WB1).Worksheets(1).Rows(i).Delete
i = i - 1
k = k + 1
NextRow = Application.WorksheetFunction.CountA(Range("A:A"))
Last_Row = NextRow
Application.CutCopyMode = False
End If
Next i

--
Valeria