Sub sdds()
Application.ScreenUpdating = False
Dim col As New Collection, i As Long, lr As Long, n As Long, sh As Worksheet, sh2 As Worksheet, sh3 As Worksheet
Set sh = Worksheets("ФИО и должность людей"): Set sh2 = Worksheets("ТЛР"): Set sh3 = Worksheets("шаблон для ТЛР")
sh2.Cells(2, 3) = "по состоянию на " & Date

lcol = Cells(5, Columns.Count).End(xlToLeft).Column
If Cells(5, Columns.Count).End(xlToLeft).Column > 6 Then
    sh2.Range(Cells(1, 4), Cells(1048576, lcol - 3)).Delete Shift:=xlToLeft
End If
        sh3.Range("A:B").Copy
        sh2.Range("D:E").Insert Shift:=xlToRight
lr = sh.Cells(Rows.Count, 1).End(xlUp).Row
For i = 2 To lr
    On Error Resume Next
    If sh.Cells(i, 6) <> Empty Then
    col.Add sh.Cells(i, 6), CStr(sh.Cells(i, 6))
    End If
Next i
k = 4
For i = col.Count To 1 Step -1
    sh2.Range(sh2.Cells(4, k), sh2.Cells(4, k + 1)).Merge
    sh2.Cells(4, k) = col(i)
    For n = 6 To 88
        x1 = Application.WorksheetFunction.CountIfs(sh.Columns(6), col(i), sh.Columns(3), sh2.Cells(n, 2), sh.Columns(5), "День")
        x2 = Application.WorksheetFunction.CountIfs(sh.Columns(6), col(i), sh.Columns(3), sh2.Cells(n, 2), sh.Columns(5), "Ночь")
        If x1 > 0 Then sh2.Cells(n, k) = x1
        If x2 > 0 Then sh2.Cells(n, k + 1) = x2
    Next n
    If i > 1 Then
        sh3.Range("A:B").Copy
        sh2.Range("D:E").Insert Shift:=xlToRight
    Else
        Exit For
    End If
Next i
Application.ScreenUpdating = True
End Sub

Sub sdds()
Application.ScreenUpdating = False
Dim col As New Collection, i As Long, lr As Long, n As Long, sh As Worksheet, sh2 As Worksheet, sh3 As Worksheet ' объявление переменных
Set sh = Worksheets("ФИО и должность людей"): Set sh2 = Worksheets("ТЛР"): Set sh3 = Worksheets("шаблон для ТЛР") ' присваивание значений переменным
sh2.Cells(2, 3) = "по состоянию на " & Date 'подстановка текущей даты

lcol = Cells(5, Columns.Count).End(xlToLeft).Column 'последний заполненный столбец в 5 строке активного листа (ТЛР)
If Cells(5, Columns.Count).End(xlToLeft).Column > 6 Then ' проверка количества столбцов на листе ТЛР если их больше 6
    sh2.Range(Cells(1, 4), Cells(1048576, lcol - 3)).Delete Shift:=xlToLeft ' удаляем c 4 до последнего заполненного столбца минут 3
End If
        sh3.Range("A:B").Copy ' копируем столбец "ШАБЛОН"
        sh2.Range("D:E").Insert Shift:=xlToRight 'вставляем его после ед. изм и перед день ВСЕГО
lr = sh.Cells(Rows.Count, 1).End(xlUp).Row 'последняя заполненная строка в 1 столбце листа "ФИО и должность людей"
For i = 2 To lr ' цикл от 2 ячейки до последней заполненной листа "ФИО и должность людей" столбца 6
    On Error Resume Next ' отключаем появление ошибки при добавлении в коллекцию повторяющегося значения
    If sh.Cells(i, 6) <> Empty Then 'если ячейка не пустая
        col.Add sh.Cells(i, 6), CStr(sh.Cells(i, 6)) 'то добавляем ее в коллекцию уникальных
    End If
Next i ' следующая строка цикла
k = 4 'c какого столбца будут добавляться уникальные значения на лист ТЛР
For i = col.Count To 1 Step -1 ' цикл по значениям коллекции от последнего до первого
    sh2.Range(sh2.Cells(4, k), sh2.Cells(4, k + 1)).Merge 'объединение ячеек столбца к  и к+1
    sh2.Cells(4, k) = col(i) ' вставка значения из коллекции по порядку
    For n = 6 To 88 'цикл от 6 строки до 88 листа ТЛР
        x1 = Application.WorksheetFunction.CountIfs(sh.Columns(6), col(i), sh.Columns(3), sh2.Cells(n, 2), sh.Columns(5), "День") ' подсчет количества ячеек на листе "ФИО и должность людей" с режимом день и титула
        x2 = Application.WorksheetFunction.CountIfs(sh.Columns(6), col(i), sh.Columns(3), sh2.Cells(n, 2), sh.Columns(5), "Ночь") ' подсчет количества ячеек на листе "ФИО и должность людей" с режимом ночь и титула
        If x1 > 0 Then sh2.Cells(n, k) = x1 'если больше нуля подставляем количество
        If x2 > 0 Then sh2.Cells(n, k + 1) = x2 ''=если больше нуля подставляем количество
    Next n 'след значение цикла т.е. следующая строка
    If i > 1 Then 'если переменная больше 1 то добавляем новые столбцы для следующего значения титула
        sh3.Range("A:B").Copy ' копируем столбец "ШАБЛОН"
        sh2.Range("D:E").Insert Shift:=xlToRight 'вставляем его после ед. изм и перед день ВСЕГО
    Else 'если переменная равна 1 то не добавляем шаблон столбца т.к. это последнее значение и добавление столбцов из шаблона приведет к пустому столбцу поэтому
        Exit For ' выходим из цикла
    End If
Next i
Application.ScreenUpdating = True
End Sub