I have the code below works fine the only problem it overwrites the records already there and I want to keep old records, how to make to copy new records the next available blank row the new records copy:
thanks.
VBA Code:
Sub COPY_PAIDINVOICES()On Error Resume Next
Dim srchtrm As String
Dim rng As Range, destRow As Long
Dim shtSrc As Worksheet, shtDest As Worksheet
Dim c As Range
Dim i As Integer
Dim Today As Date
With Application
.ScreenUpdating = False
.DisplayStatusBar = False
.Calculation = xlCalculationManual
.EnableEvents = False
End With
Set shtSrc = Sheets("CDA_INVOICES") 'source sheet
Set shtDest = Sheets("PAID_INVOICES") 'destination sheet
destRow = 2 'start copying to this row
'don't scan the entire column...
Set rng = Application.Intersect(shtSrc.Range("H:H"), shtSrc.UsedRange)
For Each c In rng.Cells
If c.Value = "PAID IN FULL" Then
'Range(Cells(c.Row, "A"), Cells(c.Row, "F")).Copy shtDest.Cells(destRow, 1)
Range(Cells(c.Row, "A"), Cells(c.Row, "F")).Copy
shtDest.Cells(destRow, 1).PasteSpecial xlPasteValues
c.EntireRow.ClearContents
'c.EntireRow.Copy shtDest.Cells(destRow, 1)
destRow = destRow + 1
End If
Next
With Application
.ScreenUpdating = True
.DisplayStatusBar = True
.Calculation = xlCalculationAutomatic
.EnableEvents = True
End With
Application.CutCopyMode = False
Sheets("CDA_INVOICES").Range("H14").Select
End Sub
thanks.