VB Novice...Find and Move Cells...

If you need also companies code you can add blue row:

Sub x()
   Dim r As Long, f As Range
    
   With Sheets(1).UsedRange
      Set f = .Cells(1, 1)
      For r = 1 To WorksheetFunction.CountIf(.Cells, "Employees")
         Set f = .Find(What:="Employees", After:=f, LookIn:=xlValues, Lookat:=xlWhole, MatchCase:=False)
         'copy company
         .Cells(f.Row, "i").Copy Sheets(2).Cells(Rows.Count, 1).End(xlUp)(2)         'copy employees data
         f.Offset(, 1).Resize(, 3).Copy Sheets(2).Cells(Rows.Count, 2).End(xlUp)(2)
      Next r
   End With
End Sub

Regards,
Antonio