Try:
Sub CopyRows()
    Application.ScreenUpdating = False
    Dim bottomD As Integer
    Dim ws As Worksheet
    Dim rng As Range
    Dim strToFind As String
    strToFind = InputBox("Enter the Action Item On")
    For Each ws In Sheets
        If ws.Name <> "Master" Then
            ws.Activate
            bottomD = Range("D" & Rows.Count).End(xlUp).Row
            For Each rng In Range("D2:D" & bottomD)
                If rng = strToFind Then
                    rng.EntireRow.Copy Sheets("Master").Cells(Rows.Count, "A").End(xlUp).Offset(1, 0)
                End If
            Next rng
        End If
    Next ws
    Application.ScreenUpdating = True
End Sub