Sub ПакетнаяОбработка()
    Dim f$, v(1 To 1, 0 To 5), n&, x
    ChDir ThisWorkbook.Path
    f = Dir("*.txt")
    On Error Resume Next
    Do While Len(f)
        Open f For Input As #1
        v(1, 0) = f
        For Each x In Split(Input(LOF(1), 1), vbLf)
            n = n + 1    'номер строки в файле
            v(1, n) = Val(Mid(x, InStr(1, x, ":", vbTextCompare) + 1))
        Next
        Close 1
        f = Dir
        Sheets(1).Cells(Rows.Count, 1).End(xlUp).Offset(1).Resize(, 6).Value = v
        n = 0
    Loop
End Sub

Sub Разделить_по_книгам()
    Dim oDic As Object, arrData(), arrSeparateItems(), arrTemp(), i&, n&, m&, k&
    Dim arrTemp1() '.........Правка
  
    If MsgBox("Разделить данные по книгам?", vbQuestion + vbYesNo, "Вопрос") = vbNo Then Exit Sub
    Application.ScreenUpdating = False
    arrData() = Range("A1").CurrentRegion.Value
    Set oDic = CreateObject("Scripting.Dictionary")
    For i = LBound(arrData) To UBound(arrData)
        If Not oDic.exists(arrData(i, 1)) Then oDic.Add arrData(i, 1), arrData(i, 1)
    Next i
    arrSeparateItems() = oDic.items
    For n = LBound(arrSeparateItems) + 1 To UBound(arrSeparateItems) '.........
        ReDim arrTemp(1 To UBound(arrData), 1 To UBound(arrData, 2))
        k = 0
        For i = LBound(arrData) To UBound(arrData)
            If arrData(i, 1) = arrSeparateItems(n) Then
                k = k + 1
                For m = LBound(arrData, 2) To UBound(arrData, 2)
                    arrTemp(k, m) = arrData(i, m)
                Next m
            End If
        Next i
        Workbooks.Add
                ReDim arrTemp1(1 To 1, 1 To UBound(arrData, 2)) '.........
                For m = 1 To UBound(arrData, 2) '........
                    arrTemp1(1, m) = arrData(1, m) '..........
                Next m '..........
        Range("A1").Resize(1, UBound(arrData, 2)).Value = arrTemp1 '.........
        Range("A2").Resize(UBound(arrTemp), UBound(arrTemp, 2)).Value = arrTemp
        Columns("A:E").AutoFit
        Columns("B:G").HorizontalAlignment = xlLeft
        ActiveWorkbook.SaveAs ThisWorkbook.Path & "\" & Right(arrSeparateItems(n), 10), xlExcel8
        ActiveWorkbook.Close SaveChanges:=True
    Next n
    Application.ScreenUpdating = True
    MsgBox "Данные разделены и сохранены в " & ThisWorkbook.Path & "\", vbInformation, "Конец"
End Sub

Sub Овал1_Щелчок()
    Dim r As Range, c As Range
    Application.ScreenUpdating = 0
    ActiveSheet.ListObjects("Table1").Unlist
    Set r = Sheets(2).Range("B2:B" & Cells(Rows.Count, 2).End(xlUp).Row)
    r.ClearOutline
    For Each c In r
        If Not (Cells(c.Row, 1) = "" And Cells(c.Row, 2) <> "" And Cells(c.Row, 3) = "") Then
            c.EntireRow.Group
        End If
    Next
    r.Resize(r.Rows.Count).EntireRow.Group
    ActiveSheet.ListObjects.Add(xlSrcRange, r.CurrentRegion, , xlYes).Name = "Table1"
End Sub

Sub Овал1_Щелчок()
    Dim r As Range, c As Range
    Application.ScreenUpdating = 0
    Set r = Sheets(1).Range("B2:B" & Cells(Rows.Count, 2).End(xlUp).Row)
    r.ClearOutline
    For Each c In r
        If Not (Cells(c.Row, 1) = "" And Cells(c.Row, 2) <> "" And Cells(c.Row, 3) = "") Then
            c.EntireRow.Group
        End If
    Next
End Sub

Private Sub Worksheet_Activate()
    Dim sh As Worksheet, r As Range, c As Range, j&
    Range("A2:D1000").ClearContents: j = 1
    For Each sh In Worksheets
        Set r = sh.Range("B3:AH5")    'ваш табель
        If sh.Name <> "Учет отгулов" Then
            For Each c In r
                If Not c.Comment Is Nothing Then
                    j = j + 1
                    Cells(j, 1) = c.EntireRow.Cells(2)
                    Cells(j, 2) = c.EntireColumn.Cells(2)
                    Cells(j, 3) = c.Comment.Text
                    Cells(j, 4) = c.EntireColumn.Cells(1)
                End If
            Next
        End If
    Next
    Set r = [A1].CurrentRegion
    With ActiveSheet.Sort
        .SortFields.Clear
        .SortFields.Add Key:=[A1]
        .SortFields.Add Key:=[D1]
        .SortFields.Add Key:=[B1]
        .SetRange r
        .Header = xlYes
        .MatchCase = False
        .Orientation = xlTopToBottom
        .Apply
    End With
End Sub

Private Sub Worksheet_Activate()
    Dim sh As Worksheet, r As Range, c As Range, j&
    Range("A2:D1000").ClearContents: j = 1
    For Each sh In Worksheets
        Set r = sh.Range("B3:AH5")    'ваш табель
        If sh.Name <> "Учет отгулов" Then
            For Each c In r
                If Not c.Comment Is Nothing Then
                    j = j + 1
                    Cells(j, 1) = c.EntireRow.Cells(2)
                    Cells(j, 2) = c.EntireColumn.Cells(2)
                    Cells(j, 3) = c.Comment.Text
                    Cells(j, 4) = c.EntireColumn.Cells(1)
                End If
            Next
        End If
    Next
End Sub

Sub tt()
    Dim r As Range, i&
    With Sheets("Основа")
        Set r = Range("A1:E" & .[A1].End(xlDown).Row)
        On Error GoTo rpt
        For i = 2 To r.Rows.Count
            If Len(Worksheets(Sheets(1).Range("A" & i).Value).Name) > 0 Then
                Sheets(.Range("A" & i).Value).Range("C1") = .Range("A" & i)
                Sheets(.Range("A" & i).Value).Range(.Range("C" & i)) = .Range("B" & i)
                Sheets(.Range("A" & i).Value).Range(.Range("E" & i)) = .Range("D" & i)
            End If
rpt:
            If Err Then MsgBox "Такого листа " & """" & .Range("A" & i) & """" & " нет!"
        Next
    End With
End Sub