VBA: Serach column for date, cut then paste row into new sheet

[Pivol]

Could some kind soul please advise me on VBA coding to complete the following;

1. Search the Completed column (G) of the ToDo List worksheet for any date entries.
2. If any entry found to cut and paste the entire row(s) onto the Archive worksheet (Ensuring they are pasted into the next free row).
3. Re-sort the ToDo List worksheet into order for QofA (smallest to largest), then by To Do (oldest to newest)

If this could be placed into a button then super, but tbh this is just a nice addition.

Example Worksheet

QofA	UID	Link	To Do	Ref	Task	Completed	Comments
1	3		13/02/15		Test 1	13/02/15	SAP updated.
1	2		14/02/15		Test 2
2	4		16/02/15		Test 3	15/02/15	Task delegated ABV.
3	5		13/02/15		Test 4
4	7		20/02/15		Test 5

<tbody>
</tbody>

Thanks in advance.

Regards,
Clive

 

[mumps]

Hi Clive. Try:

Sub CopyRows()
    Application.ScreenUpdating = False
    Dim LastRow As Long
    LastRow = Sheets("ToDo List").Cells.Find("*", SearchOrder:=xlByRows, SearchDirection:=xlPrevious).Row
    Sheets("ToDo List").Range("$A$1:$H$" & LastRow).AutoFilter Field:=7, Criteria1:="<>"
    Sheets("ToDo List").Range("$A$2:$H$" & LastRow).SpecialCells(xlCellTypeVisible).EntireRow.Copy Sheets("Archive").Cells(Rows.Count, "A").End(xlUp).Offset(1, 0)
    Sheets("ToDo List").Range("$A$2:$H$" & LastRow).SpecialCells(xlCellTypeVisible).EntireRow.Delete
    If Sheets("ToDo List").FilterMode Then Sheets("ToDo List").ShowAllData
    Application.ScreenUpdating = True
End Sub

 

[Pivol]

Hi Clive. Try:

Sub CopyRows()
    Application.ScreenUpdating = False
    Dim LastRow As Long
    LastRow = Sheets("ToDo List").Cells.Find("*", SearchOrder:=xlByRows, SearchDirection:=xlPrevious).Row
    Sheets("ToDo List").Range("$A$1:$H$" & LastRow).AutoFilter Field:=7, Criteria1:="<>"
    Sheets("ToDo List").Range("$A$2:$H$" & LastRow).SpecialCells(xlCellTypeVisible).EntireRow.Copy Sheets("Archive").Cells(Rows.Count, "A").End(xlUp).Offset(1, 0)
    Sheets("ToDo List").Range("$A$2:$H$" & LastRow).SpecialCells(xlCellTypeVisible).EntireRow.Delete
    If Sheets("ToDo List").FilterMode Then Sheets("ToDo List").ShowAllData
    Application.ScreenUpdating = True
End Sub

A HUGE thank you ever so much...this has been bugging me something rotten and is now resolved.

 

[mumps]

My pleasure.