Sub cpy()
Dim rRange As Range, rCell As Range, r&, i&
Dim hat As Range
Dim all
all = Array("Учет работников", "учет личных дел", "учет карточек", "еще учет")
Set hat = Sheets(1).[a8:f10]
           With Application
               For i = 0 To UBound(all)
                   Set rCell = Sheets(1).Cells.Find(all(i)).Offset(1, 0)
                       r = rCell.Offset(0, 1).End(xlDown).Row - rCell.Row + 1
                   Set rRange = rCell.Resize(r, 6)
                       Sheets.Add After:=Sheets(Sheets.Count)
                       Sheets(Sheets.Count).Name = all(i)
                       hat.Copy Sheets(Sheets.Count).[a1]
                       rRange.Copy Sheets(Sheets.Count).[a4]
               Next
           End With
End Sub

Sub недостающие_номера() 'Так лучше?  
Dim x
Dim mx&
Dim i&, r&, g&: g = 0
Dim arRes&(1 To 100000, 1 To 1)
Dim exists As Boolean: exists = False

mx = Application.WorksheetFunction.max([a13:a1500])
x = [a13:a1500]

For i = 0 To mx
exists = False
      For r = 1 To UBound(x)
              If x(r, 1) = i Then
                  exists = True
              End If
      Next
      If exists = False Then
      g = g + 1
          arRes(g, 1) = i
      End If
Next
If g = 0 Then Exit Sub
[h1].Resize(g) = arRes
End Sub