filter cell value and copy/paste

[asyamonique]

Dim LR As Long, i As Long
LR = Range("AM" & Rows.Count).End(xlUp).Row
For i = 1 To LR
With Range("AM" & i)
If .Value = Range("A1").Value Then
.Offset(, 1).Resize(, 26).Copy
Range("D" & Rows.Count).End(xlUp).Offset(1).PasteSpecial Paste:=xlPasteValues
End If
End With
Next i

Good Day,
How can we improve the above code to increase the range targets like in same time i will get the A1:A10 values instead of getting only one cell value?
Many Thanks

 

[AlphaFrog]

This uses the .AutoFilter method to filter column AM for each filter value in A2:A11. It then copies the filtered results to column D.
Note: AutoFilter presumes the top row is a header row. The code copies filtered results in columns AN:BN starting from from row 2.

    Dim LR As Long
    Dim rngFilterVals As Range, c As Range, rngResult As Range, NextCell As Range
    
    Set rngFilterVals = Range("A2:A11")
    
    LR = Range("AM" & Rows.Count).End(xlUp).Row
    
    Application.ScreenUpdating = False
    
    For Each c In rngFilterVals
        If Not Range("AM1:AM" & LR).Find(c.Value, , xlValues, xlWhole, , , False) Is Nothing Then
            Set NextCell = Range("D" & Rows.Count).End(xlUp).Offset(1)
            Range("AM1:AM" & LR).AutoFilter Field:=1, Criteria1:=c.Value
            Range("AN2:BN" & LR).SpecialCells(xlCellTypeVisible).Copy
            NextCell.PasteSpecial Paste:=xlPasteValues
            Range("AM1:AM" & LR).AutoFilter
        End If
    Next c

    ActiveSheet.AutoFilterMode = False
    Application.CutCopyMode = True
    Application.ScreenUpdating = True

 

[asyamonique]

Thanks Alpha,
Cheers