Option Explicit
Sub Books()
Dim s1 As Worksheet, s2 As Worksheet
Set s1 = Sheets("Sheet1")
Set s2 = Sheets("Sheet2")
Dim lr As Long, lr2 As Long
lr = s1.Range("A" & Rows.Count).End(xlUp).Row
Dim i As Long
Dim crit1 As String, crit2 As String, crit3 As String, crit4 As String
crit1 = "Calculus": crit2 = "Modelling": crit3 = "Fluid": crit4 = "Probability"
Application.ScreenUpdating = False
s1.Range("A2:D2").Copy s2.Range("A1")
For i = 3 To lr
lr2 = s2.Range("A" & Rows.Count).End(xlUp).Row
If InStr(s1.Range("B" & i), crit1) > 0 Then
s1.Range("A" & i & ":D" & i).Copy s2.Range("A" & lr2 + 1)
End If
Next i
For i = 3 To lr
lr2 = s2.Range("A" & Rows.Count).End(xlUp).Row
If InStr(s1.Range("B" & i), crit2) > 0 Then
s1.Range("A" & i & ":D" & i).Copy s2.Range("A" & lr2 + 1)
End If
Next i
For i = 3 To lr
lr2 = s2.Range("A" & Rows.Count).End(xlUp).Row
If InStr(s1.Range("B" & i), crit3) > 0 Then
s1.Range("A" & i & ":D" & i).Copy s2.Range("A" & lr2 + 1)
End If
Next i
For i = 3 To lr
lr2 = s2.Range("A" & Rows.Count).End(xlUp).Row
If InStr(s1.Range("B" & i), crit4) > 0 Then
s1.Range("A" & i & ":D" & i).Copy s2.Range("A" & lr2 + 1)
End If
Next i
Application.CutCopyMode = False
Application.ScreenUpdating = True
MsgBox "Completed"
End Sub