Option Explicit

Sub ПреобразИНастроитьТабСиФИО()
' Объединенный макрос: сначала очищает таблицу от ненужных столбцов,
' затем настраивает ширину столбцов, обрабатывает столбец "Жизненный цикл",
' создает умную таблицу и добавляет информацию о дате/времени в строку 1
    
    'Отключаем обновление экрана для скорости выполнения
    Application.ScreenUpdating = False
    On Error GoTo ErrorHandler
    
    '=== ЧАСТЬ 1: Очистка и подготовка ===
    CloseEmptyWb
    ActiveSheet.Copy
    
    'Удаляем ненужные столбцы
    Dim xx As Long, colName As Variant
    Dim colsToRemove As Variant
    colsToRemove = Array("Приоритет", "Тип", "Осталось на выполнение", "Категории", "Исполнители")
    
    'Идем с конца, чтобы не нарушить индексацию
    For xx = ActiveSheet.UsedRange.Columns.Count To 1 Step -1
        If Not IsEmpty(Cells(1, xx).Value) Then
            For Each colName In colsToRemove
                If Trim(Cells(1, xx).Value) = Trim(colName) Then
                    Columns(xx).Delete
                    Exit For
                End If
            Next
        End If
    Next
    
    'Удаляем скопированную кнопку (если есть)
    Dim shp As Shape
    For Each shp In ActiveSheet.Shapes
        If shp.Type = msoFormControl Then
            shp.Delete
            Exit For
        End If
    Next shp
    
    '=== ЧАСТЬ 1.5: Обработка столбца "Жизненный цикл" ===
    ОбработатьЖизненныйЦикл
    
    '=== ЧАСТЬ 2: Настройка ширины столбцов ===
    Const WIDTH_B As Double = 10.86
    Const WIDTH_C As Double = 40.86
    Const WIDTH_D As Double = 14.86
    Const WIDTH_E As Double = 30.71
    Const WIDTH_G As Double = 30.71
   
    With ActiveSheet
        If .UsedRange.Columns.Count >= 2 Then .Columns("B").ColumnWidth = WIDTH_B
        If .UsedRange.Columns.Count >= 3 Then .Columns("C").ColumnWidth = WIDTH_C
        If .UsedRange.Columns.Count >= 4 Then .Columns("D").ColumnWidth = WIDTH_D
        If .UsedRange.Columns.Count >= 5 Then .Columns("E").ColumnWidth = WIDTH_E
        If .UsedRange.Columns.Count >= 7 Then .Columns("G").ColumnWidth = WIDTH_G
    End With
    
    '=== ЧАСТЬ 3: Создание умной таблицы ===
    Dim tbl As ListObject
    Dim lastRow As Long
    Dim lastCol As Long
    
    With ActiveSheet
        lastRow = .Cells(.Rows.Count, "A").End(xlUp).Row
        lastCol = .UsedRange.Columns.Count
        
        If lastRow > 0 And lastCol > 0 Then
            Set tbl = .ListObjects.Add(xlSrcRange, _
                .Range(.Cells(1, 1), .Cells(lastRow, lastCol)), _
                , xlYes)
            
            With tbl
                .Name = "Таблица1"
                .TableStyle = "TableStyleLight13"
                
                On Error Resume Next
                .ShowTotals = True
                
                Dim col As ListColumn
                For Each col In .ListColumns
                    Select Case col.Name
                        Case "Статус"
                            col.TotalsCalculation = xlTotalsCalculationCount
                        Case "Изменена"
                            col.TotalsCalculation = xlTotalsCalculationNone
                    End Select
                Next col
                On Error GoTo ErrorHandler
            End With
            
            tbl.Range.Select
        Else
            MsgBox "Нет данных для создания таблицы!", vbExclamation, "Предупреждение"
        End If
    End With
    
    '=== ЧАСТЬ 4: Добавление информации о дате и времени в строку 1 ===
    ДобавитьДатуВремяВСтроку1
    
    Application.ScreenUpdating = True
    Exit Sub

ErrorHandler:
    Application.ScreenUpdating = True
    MsgBox "Произошла ошибка: " & Err.Description, vbCritical, "Ошибка"
End Sub

Private Sub CloseEmptyWb()
    Dim wb As Workbook
    For Each wb In Application.Workbooks
        If wb.Path = "" And wb.Name <> ThisWorkbook.Name Then
            wb.Close False
        End If
    Next
End Sub

Private Sub ОбработатьЖизненныйЦикл()
&#39; Процедура оставляет в столбце "Жизненный цикл" ТОЛЬКО разрешенные фамилии
&#39; Всё остальное (инициалы, должности, лишний текст) удаляется
    
    Dim ws As Worksheet
    Dim foundCol As Range
    Dim lastRow As Long
    Dim i As Long, j As Long
    Dim cell As Range
    Dim resultValue As String
    Dim cellValue As String
    
    &#39; --- НАСТРАИВАЕМЫЙ СПИСОК РАЗРЕШЕННЫХ ФАМИЛИЙ ---
    &#39; Добавляйте или удаляйте фамилии в этом массиве
    Dim разрешенныеФамилии As Variant
    разрешенныеФамилии = Array("Панов", "Аксютин", "Аболонин", "Голубицкий", _
                               "Федотов", "Дудин", "Подрядчик", "ИП Судников", _
                               "Вересов", "Молодецкий")
    &#39; ------------------------------------------------
    
    Set ws = ActiveSheet
    
    &#39; Ищем столбец с названием "Жизненный цикл"
    On Error Resume Next
    Set foundCol = ws.Rows(1).Find(What:="Жизненный цикл", LookIn:=xlValues, LookAt:=xlWhole)
    On Error GoTo 0
    
    &#39; Если столбец не найден, выходим
    If foundCol Is Nothing Then
        MsgBox "Столбец &#39;Жизненный цикл&#39; не найден!", vbInformation, "Информация"
        Exit Sub
    End If
    
    &#39; Определяем последнюю заполненную строку
    lastRow = ws.Cells(ws.Rows.Count, foundCol.Column).End(xlUp).Row
    
    &#39; Если только заголовок, выходим
    If lastRow < 2 Then Exit Sub
    
    Dim foundCount As Long
    foundCount = 0
    
    &#39; Обрабатываем каждую ячейку в столбце (начиная со 2 строки)
    For i = 2 To lastRow
        Set cell = ws.Cells(i, foundCol.Column)
        
        If Not IsEmpty(cell.Value) Then
            cellValue = CStr(cell.Value)
            resultValue = ""
            
            &#39; Проверяем каждую разрешенную фамилию
            For j = 0 To UBound(разрешенныеФамилии)
                Dim фамилия As String
                фамилия = Trim(разрешенныеФамилии(j))
                
                &#39; Ищем фамилию в тексте (без учета регистра)
                If InStr(1, cellValue, фамилия, vbTextCompare) > 0 Then
                    &#39; Добавляем фамилию в результат (сохраняем оригинальный регистр из списка)
                    If resultValue = "" Then
                        resultValue = разрешенныеФамилии(j)
                    Else
                        &#39; Если найдено несколько фамилий, разделяем запятой
                        resultValue = resultValue & ", " & разрешенныеФамилии(j)
                    End If
                End If
            Next j
            
            &#39; Записываем результат (только фамилии или пусто)
            If resultValue = "" Then
                cell.ClearContents  &#39; Удаляем всё, если нет разрешенных фамилий
            Else
                cell.Value = resultValue
                foundCount = foundCount + 1
            End If
        End If
    Next i
    
    &#39; Показываем статистику
    MsgBox "Обработка столбца &#39;Жизненный цикл&#39; завершена!" & vbCrLf & _
           "Найдено и оставлено записей с разрешенными фамилиями: " & foundCount & vbCrLf & _
           "Пустых строк (удалено): " & (lastRow - 1 - foundCount), _
           vbInformation, "Результат"
End Sub

Private Sub ДобавитьДатуВремяВСтроку1()
    Dim ws As Worksheet
    Dim targetCell As Range
    Dim lastCol As Long
    
    Set ws = ActiveSheet
    
    &#39; Находим последний заполненный столбец в строке 1
    lastCol = ws.Cells(1, ws.Columns.Count).End(xlToLeft).Column
    
    &#39; Целевая ячейка - первая свободная справа
    Set targetCell = ws.Cells(1, lastCol + 1)
    
    &#39; Формируем текст с датой, днем недели и временем
    Dim dateTimeText As String
    dateTimeText = Format(Date, "DD.MM.YYYY") & ", " & _
                   Format(Date, "dddd") & ", " & _
                   Format(Time, "HH:MM")
    
    &#39; Записываем значение и форматируем
    With targetCell
        .Value = dateTimeText
        .ColumnWidth = 27.29
        .RowHeight = 20
        .Interior.Color = RGB(0, 0, 255)    &#39; Синий фон
        .Font.Color = RGB(0, 0, 0)          &#39; Черный шрифт
        .Font.Bold = True
        .HorizontalAlignment = xlCenter
        .VerticalAlignment = xlCenter
        .Borders.LineStyle = xlContinuous
        .Borders.Weight = xlThin
    End With
End Sub