Thread: Extract from multiple worksheets based on one condition and output to new workbook

Use this code (updated) -

Option Explicit
        Dim i As Long
        Dim lrow As Long

        Sub report()

        Application.DisplayAlerts = False
        Application.ScreenUpdating = False

        For i = 1 To 3
            Workbooks.Add
            ActiveWorkbook.SaveAs "Bk" & i
            Workbooks("Bk" & i & ".xlsx").Worksheets(1).Range("A1").Value = "Quarter"
            Workbooks("Bk" & i & ".xlsx").Worksheets(1).Range("B1").Value = "Period"
            Workbooks("Bk" & i & ".xlsx").Worksheets(1).Range("C1").Value = "Status"
            Workbooks("Bk" & i & ".xlsx").Worksheets(1).Range("D1").Value = "Counts"
        Next i

        With ThisWorkbook.Worksheets("Master")
            lrow = .Range("A" & Rows.Count).End(xlUp).Row
            For i = 3 To lrow
                If .Range("A" & i).Value = .Range("F3").Value Or .Range("B" & i).Value = .Range("G3").Value Then
                    .Range("A" & i & ":D" & i).Copy Workbooks("Bk1.xlsx").Worksheets(1).Range("A" & Rows.Count).End(xlUp).Offset(1, 0)
                End If                            
            Next i
            With Workbooks("Bk1.xlsx")
        .Worksheets(1).Cells.EntireColumn.AutoFit
        .Worksheets(1).Cells.Locked = False
        lrow = .Worksheets(1).Range("A" & Rows.Count).End(xlUp).Row
        .Worksheets(1).Range("A1:D" & lrow).Locked = True
        .ActiveSheet.Protect DrawingObjects:=True, Contents:=True, Scenarios:=True
        .ActiveSheet.EnableSelection = xlUnlockedCells
    End With
            
            lrow = .Range("M" & Rows.Count).End(xlUp).Row
            For i = 3 To lrow
                If .Range("M" & i).Value = .Range("F3").Value Or .Range("N" & i).Value = .Range("G3").Value Then
                    .Range("M" & i & ":P" & i).Copy Workbooks("Bk2.xlsx").Worksheets(1).Range("A" & Rows.Count).End(xlUp).Offset(1, 0)
                End If
            Next i
            With Workbooks("Bk2.xlsx")
        .Worksheets(1).Cells.EntireColumn.AutoFit
        .Worksheets(1).Cells.Locked = False
        lrow = .Worksheets(1).Range("A" & Rows.Count).End(xlUp).Row
        .Worksheets(1).Range("A1:D" & lrow).Locked = True
        .ActiveSheet.Protect DrawingObjects:=True, Contents:=True, Scenarios:=True
        .ActiveSheet.EnableSelection = xlUnlockedCells
    End With
         
            lrow = .Range("T" & Rows.Count).End(xlUp).Row
            For i = 3 To lrow
                If .Range("T" & i).Value = .Range("F3").Value Or .Range("U" & i).Value = .Range("G3").Value Then
                    .Range("T" & i & ":W" & i).Copy Workbooks("Bk3.xlsx").Worksheets(1).Range("A" & Rows.Count).End(xlUp).Offset(1, 0)
                End If
            Next i
With Workbooks("Bk3.xlsx")
        .Worksheets(1).Cells.EntireColumn.AutoFit
        .Worksheets(1).Cells.Locked = False
        lrow = .Worksheets(1).Range("A" & Rows.Count).End(xlUp).Row
        .Worksheets(1).Range("A1:D" & lrow).Locked = True
        .ActiveSheet.Protect DrawingObjects:=True, Contents:=True, Scenarios:=True
        .ActiveSheet.EnableSelection = xlUnlockedCells
    End With
        End With
        
        Application.DisplayAlerts = True
        Application.ScreenUpdating = True

        End Sub