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
Bookmarks