Sub Создать_График()

    Dim ws1 As Worksheet, ws2 As Worksheet
    Dim lastRow1 As Long, lastRow2 As Long
    Dim i As Long, j As Long, k As Long
    Dim name As String
    Dim startDateTime As Date, endDateTime As Date
    Dim currentDateTime As Date
    Dim hoursDiff As Integer
    Dim presenceCount As Integer
    Dim nameColumn As Integer
    Dim uniqueNames As Collection

    ' Указываем листы
    Set ws1 = ThisWorkbook.Sheets("Лист1")
    Set ws2 = ThisWorkbook.Sheets("Лист2")

    ' Находим последнюю заполненную строку на Листе1 и Листе2
    lastRow1 = ws1.Cells(ws1.Rows.count, "B").End(xlUp).Row
    lastRow2 = ws2.Cells(ws2.Rows.count, "A").End(xlUp).Row

    ' Находим последний столбец с именами на Листе2
    nameColumn = ws2.Cells(1, ws2.Columns.count).End(xlToLeft).Column

    ' Инициализируем коллекцию для хранения уникальных имен
    Set uniqueNames = New Collection

    ' Проходим по каждой строке на Листе1
    For i = 2 To lastRow1
        ' Получаем имя
        name = ws1.Cells(i, 1).Value

        ' Проверяем, является ли имя уникальным
        On Error Resume Next
        uniqueNames.Add name, CStr(name)
        On Error GoTo 0
    Next i

    ' Добавляем уникальные имена на Лист2
    For i = 1 To uniqueNames.count
        If Application.WorksheetFunction.CountIf(ws2.Range("A:A"), uniqueNames.Item(i)) = 0 Then
            ws2.Cells(lastRow2 + i, 1).Value = uniqueNames.Item(i)
        End If
    Next i

    ' Проходим по каждой строке в Листе2 (каждому уникальному имени)
    For i = 2 To lastRow2 + uniqueNames.count
        ' Получаем имя
        name = ws2.Cells(i, 1).Value

        ' Проходим по каждой строке на Листе1
        For j = 2 To lastRow1
            ' Проверяем, совпадает ли имя на Листе1 с текущим именем на Листе2
            If ws1.Cells(j, 1).Value = name Then
                ' Получаем дату и время начала и окончания работы
                startDateTime = ws1.Cells(j, 2).Value
                endDateTime = ws1.Cells(j, 3).Value

                ' Проходим по каждому часу в промежутке между началом и окончанием работы
                For k = 0 To DateDiff("h", startDateTime, endDateTime)
                    currentDateTime = DateAdd("h", k, startDateTime)

                    ' Подсчитываем присутствие в каждом часе
                    If currentDateTime >= ws2.Cells(1, 2).Value And currentDateTime <= ws2.Cells(1, ws2.Columns.count).End(xlToLeft).Value Then
                        hoursDiff = DateDiff("h", ws2.Cells(1, 2).Value, currentDateTime) + 1
                        presenceCount = ws2.Cells(i, hoursDiff).Value
                        ws2.Cells(i, hoursDiff).Value = presenceCount + 1
                    End If
                Next k
            End If
        Next j
    Next i

    ' Форматируем данные на Листе2
    ws2.Rows(1).AutoFilter
    ws2.Columns.AutoFit

End Sub