'при активном листе кто
Sub Razbienie()
Dim i As Long
Dim iLastRow As Long
Dim iLR As Long
Dim FoundNomer As Range
Dim j As Integer
Dim Swod As Worksheet
Dim Kto As Worksheet
  Set Swod = ThisWorkbook.Worksheets("свод")
  Set Kto = ThisWorkbook.Worksheets("кто")
  For j = 1 To 8     'цикл по строке с отделами
   iLastRow = Cells(Rows.Count, j).End(xlUp).Row
     'создаем новый лист
    Worksheets.Add After:=Worksheets(Worksheets.Count)
    With Worksheets(Worksheets.Count)
      .Name = Kto.Cells(1, j)  'название листа с именем отдела
      For i = 2 To iLastRow - 1  'цикл по строкам
        Set FoundNomer = Swod.Columns(2).Find(Kto.Cells(i, j), , xlValues, xlWhole)
        If Not FoundNomer Is Nothing Then
          iLR = Cells(Rows.Count, 1).End(xlUp).Row + 1
          Cells(iLR, 1) = FoundNomer.Offset(, -1)  'дата
          Cells(iLR, 1).NumberFormat = "dd.mm.yyyy"
          Cells(iLR, 2) = FoundNomer               'номер
        End If
      Next
    End With
    Kto.Activate
  Next
End Sub

Swod.Range(Swod.Cells(FoundNomer.Row, "A"), Swod.Cells(FoundNomer.Row, "K")).Copy Cells(iLR,"A")