Copy multiple rows

[christian2016]

Im looping a range of cells in column A. If it meets a certain criteria need to copy that whole row.

Instead of individually copy and pasting the row everytime i loop when the if statement is true i want to keep adding that row to an array, collection or whatever is a better solution and once im out of the loop paste all the data in one hit.

Any help or assistance is greatly appreciated.

Thanks

 

[My Aswer Is This]

Try this:

If the value "Charlie" is found in column A that row will be copied to Sheet(2)

Sub Filter_Me_Please()
'Modified  3/23/2019  6:20:49 AM  EDT
Application.ScreenUpdating = False
Dim lastrow As Long
Dim c As Long
Dim s As Variant
c = 1 ' Column Number Modify this to your need
s = "Charlie" 'Search Value Modify to your need
lastrow = Cells(Rows.Count, c).End(xlUp).Row
With ActiveSheet.Cells(1, c).Resize(lastrow)
    .AutoFilter 1, s
    counter = .Columns(c).SpecialCells(xlCellTypeVisible).Count
    If counter > 1 Then
        .Offset(1).Resize(.Rows.Count - 1).SpecialCells(xlCellTypeVisible).EntireRow.Copy Sheets(2).Rows(1)
    Else
        MsgBox "No values found"
    End If
    .AutoFilter
End With
Application.ScreenUpdating = True
End Sub

 

[christian2016]

Works well.

How do i modify it to paste as values.

i know its in this line but unsure on how to change it

.Offset(1).Resize(.Rows.Count - 1).SpecialCells(xlCellTypeVisible).EntireRow.Copy Worksheets("Sheet2").Rows(PasteRow)

Thanks

 

[My Aswer Is This]

Try this:

Sub Filter_Me_Please()
'Modified  3/23/2019  7:08:04 AM  EDT
Application.ScreenUpdating = False
Dim lastrow As Long
Dim c As Long
Dim s As Variant
c = 1 ' Column Number Modify this to your need
s = "Charlie" 'Search Value Modify to your need
lastrow = Cells(Rows.Count, c).End(xlUp).Row
With ActiveSheet.Cells(1, c).Resize(lastrow)
    .AutoFilter 1, s
    counter = .Columns(c).SpecialCells(xlCellTypeVisible).Count
    If counter > 1 Then
        .Offset(1).Resize(.Rows.Count - 1).SpecialCells(xlCellTypeVisible).EntireRow.Copy
        Sheets(2).Rows(1).PasteSpecial xlPasteValues
    Else
        MsgBox "No values found"
    End If
    .AutoFilter
End With
Application.ScreenUpdating = True
End Sub