VBA - copy rows that contain todays date in a column and paste to another worksheets next blank row

[saj12950]

Afternoon all,

Huge thanks in advance for anyone who helps. My VBA knowledge is basic to none so please don't feel like you're patronising me by spoon feeding how I need to do this.

I need to copy all rows that contain todays date in column V and paste them into another worksheet without overwriting the data in there (so to the next blank row).

Sheet one ("Plinga Assets") contains the data and Sheet 2 ("Audit") is the destination sheet for where the rows will be stored. It would be useful for this to be done by clicking a button.

The date in column V automatically updates to todays date when changes are made to cells in that row. The idea is that the user will then click the button and it will store the changes made.

The key thing is that the information on Plinga Assets is only copied and the information on Audit appends to the bottom of the sheet.

Thanks,

Steve

 

[wideboydixon]

Attach this macro to your button:

Public Sub CopyAssetsToAudit()

Dim assetSheet As Worksheet
Dim auditSheet As Worksheet
Dim nextRow As Long
Dim lastRow As Long
Dim thisRow As Long

' Get the sheet references
Set assetSheet = Sheets("Plinga Assets")
Set auditSheet = Sheets("Audit")

' Find the last row on the asset sheet and the next row on the audit sheet
lastRow = assetSheet.Cells(assetSheet.Rows.Count, "V").End(xlUp).Row
nextRow = auditSheet.Cells(auditSheet.Rows.Count, "V").End(xlUp).Row + 1

' Look at all rows in the asset sheet
For thisRow = 1 To lastRow
    ' Check if column V contains today's date
    If assetSheet.Cells(thisRow, "V").Value = Date Then
        ' Copy the entire row to the audit sheet
        assetSheet.Cells(thisRow, "V").EntireRow.Copy Destination:=auditSheet.Cells(nextRow, "A")
        
        ' Move to the next row on the audit sheet
        nextRow = nextRow + 1
    End If
Next thisRow

End Sub

Commented to help you understand what's going on.

WBD

 

[My Aswer Is This]

Try this:

Sub Filter_Me()
'Modified 12-11-17 9:15 PM EST
Application.ScreenUpdating = False
Dim ans As String
Dim Lastrow As Long
Lastrow = Sheets("Audit").Cells(Rows.Count, "V").End(xlUp).Row + 1
ans = Date
    
        With Sheets("Plinga Assets").Range(Cells(1, "V"), Cells(Cells(Rows.Count, "V").End(xlUp).Row, "V"))
            .AutoFilter Field:=1, Criteria1:=ans
            .Offset(1).Resize(.Rows.Count - 1).SpecialCells(xlCellTypeVisible).EntireRow.Copy Sheets("Audit").Range("A" & Lastrow)
            .AutoFilter
        End With
    
    Application.ScreenUpdating = True
End Sub

 

[saj12950]

Thanks, this works perfectly.

Much appreciated.