Looping and copy matches

[VbaHell]

Hello all

I have a worksheet called "Data" with Rows "A1:W51345" and this row can grow or shrink as the data is updated.

On my Tab called "Result" in cell "A6" i want to enter a part number, for every match in "Data" column "O" I need to copy those matching rows back to my "Result" tab from Column "A10" onwards

Can anyone please help on how to do this, now sure if it should some type of vlookup or a loop of some kind

 

[mumps]

Copy and paste this macro into the worksheet code module. Do the following: right click the tab for your "Result" sheet and click 'View Code'. Paste the macro into the empty code window that opens up. Close the code window to return to your sheet. The macro assumes that row 1 in the "Data" sheet has headers and your data starts in row 2. Simply enter a part number in A6 of the "Result" sheet and exit the cell.

Private Sub Worksheet_Change(ByVal Target As Range)
    If Intersect(Target, Range("A6")) Is Nothing Then Exit Sub
    Application.ScreenUpdating = False
    Dim LastRow As Long
    LastRow = Sheets("Data").Cells.Find("*", SearchOrder:=xlByRows, SearchDirection:=xlPrevious).Row
    Sheets("Data").Range("O1:O" & LastRow).AutoFilter Field:=1, Criteria1:=Target
    Sheets("Data").Range("O2:O" & LastRow).SpecialCells(xlCellTypeVisible).EntireRow.Copy Cells(10, 1)
    Sheets("Data").Range("O1").AutoFilter
    Application.ScreenUpdating = True
End Sub

 

[My Aswer Is This]

Assuming you want the rows copied to sheet named Result stating in Row(10)
Try this.
This script is a Module script.
This script copies the entire row. If that is a problem let me know.

Sub Filter_Me_Please()
'Modified  10/21/2018  1:10:18 PM  EDT
Application.ScreenUpdating = False
Dim lastrow As Long
Dim c As Long
Dim s As Variant
Sheets("Data").Activate
c = 15 ' Column Number Modify this to your need
s = Sheets("Result").Range("A6").Value '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("Result").Cells(10, "A")
        
    Else
        MsgBox "No values found"
    End If
    .AutoFilter
End With
Application.ScreenUpdating = True
End Sub

 

[VbaHell]

Mumps thank you so much, works great

 

[VbaHell]

Hi, thanks for your reply, this also works well

 

[My Aswer Is This]

Hi, thanks for your reply, this also works well

Glad I was able to help you.
Come back here to Mr. Excel next time you need additional assistance.