Extract Rows based on Cell Value

[AndrewS6]

Hi

I'm wanting to extract rows from Data sheet into Report sheet based on criteria in cell B1 of Report sheet and column E of Data sheet.

eg. if Report sheet cell B1 = MLO I want to copy and paste all the Rows within Data sheet where column E contains MLO into the Report sheet (starting in cell C2)

Thanks
Andrew

[patel45]

Sub a()
Set sh1 = Sheets("Data")
Set sh2 = Sheets("Report")
repo = sh2.Cells(1, 2)
With sh1
lastrow = .Range("A" & Rows.Count).End(xlUp).Row
sh2initrow = 2
sh2col = 3
For j = 1 To lastrow
  If .Cells(j, 5).Value = repo Then
     .Range(.Cells(j, 1), .Cells(j, 6)).Copy sh2.Cells(sh2initrow, sh2col)
     sh2initrow = sh2initrow + 1
  End If
Next
End With
End Sub

[AndrewS6]

Thanks Patel

[Leith Ross]

Hello AndrewS6,

Welcome to the Forum!

I expanded what you asked for. Since B1's content is controlled by a validation drop down, the macro will fill the range starting at C2 with the row data. The macro is called automatically whenever B1 changes. This is accomplished by the Worksheet Change event for the Report worksheet. The macros are listed below. The attached workbook contains these changes.

Extract Rows Macro

Sub ExtractRows()
  
    Dim Cell As Range
    Dim DstRng As Range
    Dim FindWhat As Variant
    Dim LastCol As Long
    Dim r As Long
    Dim RngEnd As Range
    Dim SrcRng As Range
    
        Set SrcRng = Worksheets("Data").Range("E1")
        Set DstRng = Worksheets("Report").Range("C2")
        
        FindWhat = Worksheets("Report").Range("B1")
        
            LastCol = SrcRng.Parent.Cells(1, Columns.Count).End(xlToLeft).Column
            
            Set RngEnd = SrcRng.Parent.Cells(Rows.Count, SrcRng.Column).End(xlUp)
            If RngEnd.Row < SrcRng.Row Then Exit Sub Else Set SrcRng = SrcRng.Parent.Range(SrcRng, RngEnd)
            
                Set DstRng = DstRng.Resize(ColumnSize:=LastCol + DstRng.Column - 1)
            
                Set RngEnd = DstRng.Parent.Cells(Rows.Count, DstRng.Column).End(xlUp)
                Set DstRng = IIf(RngEnd.Row < DstRng.Row, DstRng, DstRng.Parent.Range(DstRng, RngEnd))
            
                DstRng.ClearContents
                
                For Each Cell In SrcRng
                    If Cell = FindWhat Then
                        CellRow = Cell.Offset(0, -4).Resize(ColumnSize:=LastCol).Value
                        DstRng.Offset(r, 0).Resize(1, LastCol).Value = CellRow
                        r = r + 1
                    End If
                Next Cell
            
End Sub

Report Worksheet Change Event MAcro

Private Sub Worksheet_Change(ByVal Target As Range)

    If Target.Cells.Count > 1 Then Exit Sub
    
    If Intersect(Target, Range("$B$1")) Is Nothing Then Exit Sub
    
        Application.EnableEvents = False
            Call ExtractRows
        Application.EnableEvents = True
        
End Sub

[AndrewS6]

Thanks Leith. Just what I am after

[Leith Ross]

Hello AndrewS6,

You're welcome.