VBa Copy Paste Rows with Certain values

[JMC88]

Hello,
I have the below code that works, however it only posts the first row into the sheet and not every row that meets the condition in column P. Essentially I am trying to search Open POs Finance column P for all rows that have a result that matches the value in Critique A23 (although if I can also not have it reference a cell and instead just search for Not Accrued text that would be great). The macro works, however it is only copying the first row that it hits that meets the criteria and does not copy and paste other rows below it.


Sub CopyData()

Application.ScreenUpdating = False

Dim srcWS As Worksheet, desWS As Worksheet, fnd As Range, colArr As Variant

colArr = Array("B", "A", "F", "B", "H", "C", "J", "D", "K", "E", "M", "F")

Set desWS = Sheets("Critique")

Set srcWS = Sheets("Open POs Finance")

Set fnd = srcWS.Range("P:P").Find(desWS.Range("A23").Value, LookIn:=xlValues, lookat:=xlWhole)

If Not fnd Is Nothing Then

For i = LBound(colArr) To UBound(colArr) Step 2

srcWS.Range(colArr(i) & fnd.Row).Copy desWS.Cells(desWS.Rows.Count, colArr(i + 1)).End(xlUp).Offset(1)

Next i

Else

MsgBox desWS.Range("A23") & " not found."

End If

Application.ScreenUpdating = True

End Sub

 

[mumps]

This macro should work but it the filter criteria exist in A23 of the "Critique" sheet, the code will paste the data in column A at row 24.

Sub CopyData()
    Application.ScreenUpdating = False
    Dim srcWS As Worksheet, desWS As Worksheet, colArr As Variant, lRow As Long
    colArr = Array("B", "A", "F", "B", "H", "C", "J", "D", "K", "E", "M", "F")
    Set desWS = Sheets("Critique")
    Set srcWS = Sheets("Open POs Finance")
    With srcWS
        lRow = .Cells.Find("*", SearchOrder:=xlByRows, SearchDirection:=xlPrevious).Row
        .Range("A1").CurrentRegion.AutoFilter 16, desWS.Range("A23").Value
        For i = LBound(colArr) To UBound(colArr) Step 2
            Intersect(.Rows("2:" & lRow), .Range(colArr(i) & 2 & ":" & colArr(i) & lRow).SpecialCells(xlCellTypeVisible)).Copy desWS.Cells(desWS.Rows.Count, colArr(i + 1)).End(xlUp).Offset(1)
        Next i
        .Range("A1").AutoFilter
    End With
    Application.ScreenUpdating = True
End Sub

 

[JMC88]

That works perfect! Thank you so much for the quick response. One last question- can I get it to only paste the values on the Critique tab so that it keeps the formatting from the Critique tab and not the Open POs Finance that it copied from?

 

[mumps]

Try:

Sub CopyData()
    Application.ScreenUpdating = False
    Dim srcWS As Worksheet, desWS As Worksheet, colArr As Variant, lRow As Long
    colArr = Array("B", "A", "F", "B", "H", "C", "J", "D", "K", "E", "M", "F")
    Set desWS = Sheets("Critique")
    Set srcWS = Sheets("Open POs Finance")
    With srcWS
        lRow = .Cells.Find("*", SearchOrder:=xlByRows, SearchDirection:=xlPrevious).Row
        .Range("A1").CurrentRegion.AutoFilter 16, desWS.Range("A23").Value
        For i = LBound(colArr) To UBound(colArr) Step 2
            Intersect(.Rows("2:" & lRow), .Range(colArr(i) & 2 & ":" & colArr(i) & lRow).SpecialCells(xlCellTypeVisible)).Copy
            desWS.Cells(desWS.Rows.Count, colArr(i + 1)).End(xlUp).Offset(1).PasteSpecial xlPasteValues
        Next i
        .Range("A1").AutoFilter
    End With
    Application.CutCopyMode = False
    Application.ScreenUpdating = True
End Sub

 

[JMC88]

Yes- that is perfect. Thank you so much!!!

 

[mumps]

My pleasure.