Sub ВывестиРезультаты()
Dim dict As Object
Set dict = CreateObject("Scripting.Dictionary")

vbnet
Copy code
Dim wsInput As Worksheet
' Dim wsOutput As Worksheet
Dim i As Integer
Dim lastRow As Long

vbnet
Copy code
' Указываем название листа с исходными данными
Set wsInput = ThisWorkbook.Sheets("Лист2")

' Указываем название листа для вывода результатов
' Set wsOutput = ThisWorkbook.Sheets("Результаты")

vbnet
Copy code
'Находим последнюю заполненную строку в колонке А
lastRow = wsInput.Cells(wsInput.Rows.Count, 1).End(xlUp).row

'Добавление всех записей из таблицы в словарь
For i = 2 To lastRow
    Dim name As String
    Dim dateTime As String
    Dim status As String
    
    name = wsInput.Cells(i, 1).value
    dateTime = wsInput.Cells(i, 2).value
    status = wsInput.Cells(i, 3).value
    
    If Not dict.Exists(name) Then
        dict.Add name, Array(New Collection, New Collection)
    End If
    
    dict(name)(0).Add dateTime
    dict(name)(1).Add status
Next i
'Вывод отсутствия
' Создаем новый лист для вывода сообщений об опозданиях и ранних выходах
Dim wsTimeIssues As Worksheet
Set wsTimeIssues = ThisWorkbook.Sheets.Add(After:=ThisWorkbook.Sheets(ThisWorkbook.Sheets.Count))
wsTimeIssues.name = "Временные Проблемы"

' Очищаем новый лист перед использованием
wsTimeIssues.Cells.Clear
wsTimeIssues.Cells(1, 1).value = "ФИО"
wsTimeIssues.Cells(1, 2).value = "Событие"
wsTimeIssues.Cells(1, 3).value = "Дата"
wsTimeIssues.Cells(1, 4).value = "Время"
Dim timeIssueRow As Long
timeIssueRow = 2

' Перебираем каждую запись из словаря
For Each key In dict.Keys
Dim coll As Variant
coll = dict(key)

vbnet
Copy code
Dim entryCount As Integer
Dim exitCount As Integer
entryCount = 0
exitCount = 0

For i = 1 To coll(0).Count
    If coll(1)(i) = "Вход" Then
        entryCount = entryCount + 1
    ElseIf coll(1)(i) = "Выход" Then
        exitCount = exitCount + 1
    End If
Next i

' Выводим сообщения об отсутствии входа или выхода
If entryCount = 0 Then
    wsTimeIssues.Cells(timeIssueRow, 1).value = key
    wsTimeIssues.Cells(timeIssueRow, 2).value = "Отсутствие входа"
    wsTimeIssues.Cells(timeIssueRow, 3).value = Format((coll(0)(coll(0).Count)), "dd.mm.yyyy") ' вывод отс входа
    timeIssueRow = timeIssueRow + 1
End If

If exitCount = 0 Then
    wsTimeIssues.Cells(timeIssueRow, 1).value = key
    wsTimeIssues.Cells(timeIssueRow, 2).value = "Отсутствие выхода"
    wsTimeIssues.Cells(timeIssueRow, 3).value = Format((coll(0)(coll(0).Count)), "dd.mm.yyyy") ' вывод отс выхода

    timeIssueRow = timeIssueRow + 1
End If

' Проверка временного интервала для последней записи входа
If entryCount > 0 Then
    Dim lastEntry As String
    lastEntry = coll(0)(coll(0).Count)
    Dim entryTime As Date
    entryTime = TimeValue(Split(lastEntry, " ")(1)) ' Получаем время из строки
    Dim entryDate As Date
    entryDate = DateValue(Split(lastEntry, " ")(0)) ' Получаем дату из строки
    
    If entryTime >= TimeValue("08:02") And entryTime <= TimeValue("08:45") Then
        wsTimeIssues.Cells(timeIssueRow, 1).value = key
        wsTimeIssues.Cells(timeIssueRow, 2).value = "Опоздание"
        wsTimeIssues.Cells(timeIssueRow, 3).value = entryDate ' Добавляем дату в третью колонку
        wsTimeIssues.Cells(timeIssueRow, 4).value = entryTime ' Добавляем время в четвертую колонку
        timeIssueRow = timeIssueRow + 1
    End If
End If

' Проверка временного интервала для последней записи выхода
If exitCount > 0 Then
    Dim lastExit As String
    lastExit = coll(0)(coll(0).Count)
    Dim exitTime As Date
    exitTime = TimeValue(Split(lastExit, " ")(1)) ' Получаем время из строки
    Dim exitDate As Date
    exitDate = DateValue(Split(lastExit, " ")(0)) ' Получаем дату из строки
    
    If (Weekday(exitTime) <> vbFriday And exitTime >= TimeValue("09:45") And exitTime <= TimeValue("16:58")) Or _
       (Weekday(exitTime) = vbFriday And exitTime >= TimeValue("09:45") And exitTime <= TimeValue("15:43")) Then
        wsTimeIssues.Cells(timeIssueRow, 1).value = key
        wsTimeIssues.Cells(timeIssueRow, 2).value = "Ранний выход"
        wsTimeIssues.Cells(timeIssueRow, 3).value = exitDate ' Добавляем дату в третью колонку
        wsTimeIssues.Cells(timeIssueRow, 4).value = exitTime ' Добавляем время в четвертую колонку
        timeIssueRow = timeIssueRow + 1
    End If
End If
Next key

End Sub

Если у ФИО отсутствует запись о входе и выходе, добавить запись отсутствие на рабочем месте