Hi

Try this. It doesn't have any formatting, but I think it does bring across the relevant data.

Sub aaa()
  Dim OutSH As Worksheet
  Set OutSH = Sheets("Sheet2")
  OutSH.Range("A:D").ClearContents
  OutSH.Range("A1:D2").Value = Range("A1:D2").Value
  
  Set findit = Range("D:D").Find(what:="ALERT")
  If Not findit Is Nothing Then
    firstadd = findit.Address
    Do
      begrow = Cells(findit.Row, "C").End(xlUp).Row
      endrow = Cells(findit.Row, "C").End(xlDown).Row
      
      Set findit2 = OutSH.Range("A:A").Find(what:=Range("A" & begrow))
      If findit2 Is Nothing Then 'an instance does not exist
        Range("A" & begrow & ":D" & endrow).Copy
        OutSH.Cells(Rows.Count, 1).End(xlUp).Offset(2, 0).PasteSpecial (xlPasteValues)
      End If
      Set findit = Range("D:D").Find(what:="ALERT", after:=findit)
    Loop Until findit.Address = firstadd
  End If
  
  Application.CutCopyMode = False
End Sub
rylo