КопирЗаголовТабТрансп

Sub GenerateTableHeadersTransposed_ActiveWorkbook()
    Dim ws As Worksheet
    Dim tbl As ListObject
    Dim headerWs As Worksheet
    Dim tempWs As Worksheet
    Dim nextRow As Long
    Dim headerCell As Range
    Dim i As Long
    Dim lastRow As Long, lastCol As Long
    Dim wb As Workbook
    
    ' Устанавливаем активную книгу
    Set wb = ActiveWorkbook
    
    ' Удаляем существующие временные листы, если они есть
    On Error Resume Next
    Application.DisplayAlerts = False
    wb.Worksheets("Table_Headers_Temp").Delete ' Удаляем лист "Table_Headers_Temp", если он существует
    wb.Worksheets("Table_Headers_Transposed").Delete ' Удаляем лист "Table_Headers_Transposed", если он существует
    Application.DisplayAlerts = True
    On Error GoTo 0
    
    ' Создаем новый лист для временного списка заголовков таблиц
    Set tempWs = wb.Worksheets.Add
    tempWs.Name = "Table_Headers_Temp"
    
    ' Устанавливаем начальную строку для записи заголовков
    nextRow = 1
    
    ' Проходим по всем листам активной книги
    For Each ws In wb.Worksheets
        ' Пропускаем листы "Список листов", "Table_Headers_Temp" и "Table_Headers_Transposed"
        If ws.Name <> "Список листов" And ws.Name <> "Table_Headers_Temp" And ws.Name <> "Table_Headers_Transposed" Then
            ' Проходим по всем таблицам на листе (ListObjects)
            For Each tbl In ws.ListObjects
                ' Записываем название листа и таблицы во временный лист
                tempWs.Cells(nextRow, 1).value = ws.Name
                tempWs.Cells(nextRow, 2).value = tbl.Name
                
                ' Записываем каждый заголовок в отдельную колонку, начиная с 3-й
                i = 3
                For Each headerCell In tbl.HeaderRowRange
                    tempWs.Cells(nextRow, i).value = headerCell.value
                    i = i + 1
                Next headerCell
                
                nextRow = nextRow + 1
            Next tbl
        End If
    Next ws
    
    ' Создаем новый лист для транспонированных заголовков
    Set headerWs = wb.Worksheets.Add
    headerWs.Name = "Table_Headers_Transposed"
    
    ' Копируем данные с временного листа и транспонируем их на новый лист
    With tempWs
        lastRow = .Cells(.Rows.Count, 1).End(xlUp).Row
        lastCol = .Cells(1, .Columns.Count).End(xlToLeft).Column
        
        ' Копируем данные без заголовков
        .Range(.Cells(1, 1), .Cells(lastRow, lastCol)).Copy
        
        ' Вставляем транспонированные данные на новый лист
        headerWs.Range("A1").PasteSpecial Paste:=xlPasteAll, Operation:=xlNone, SkipBlanks:=False, Transpose:=True
    End With
    
    ' Удаляем временный лист
    Application.DisplayAlerts = False
    tempWs.Delete
    Application.DisplayAlerts = True
    
    ' Автоширина колонок для удобства чтения
    headerWs.Columns.AutoFit
    
    ' Сообщаем пользователю, что операция завершена
    MsgBox "Table headers have been successfully transposed."
End Sub