Страницы: 1
RSS
Дополнить макрос
 
Добрый день!
Нужна помощь в корректировки макроса.

У меня есть таблица эксель с данными, куда добавлен макрос на выгрузку данных с определенного листа.
Необходимо, чтобы по диапазону  таблицы Set rng = ws.Range("A18:M41") при выгрузке повторять заголовок ("A18:M18")на каждой странице, если таблица вся на 1 лист не будет умещаться.
Сделать это в ручную в самом файле ворд тоже не получается, так как таблица выгружаемая и кнопка "повторять заголовок на каждой странице" не активна

Sub ExportToWord()
   Dim wdApp As Object, wdDoc As Object
   Dim ws As Worksheet
   Dim rng As Range
   Dim wordTemplatePath As String
   Dim outputPath As String
   Dim fileName As String
   
   ' Путь к шаблону Word и выходному файлу
   wordTemplatePath = "C:\Users\m.stepanova\Desktop\тест\Шаблон_тест-спека.docx"
   outputPath = "C:\Users\m.stepanova\Desktop\тест\"
   fileName = "Результат_" & Format(Now(), "yyyy-mm-dd_hh-mm") & ".docx"
   
   ' Лист и диапазон данных в Excel
   Set ws = ThisWorkbook.Sheets("Спецификация")
   Set rng = ws.Range("A1:M17") ' Укажите нужный диапазон
   Set rng = ws.Range("A18:M41")
   Set rng = ws.Range("A1:M100")
   
   ' Создаем объект Word
   On Error Resume Next
   Set wdApp = GetObject(, "Word.Application")
   If wdApp Is Nothing Then Set wdApp = CreateObject("Word.Application")
   On Error GoTo 0
   
   ' Открываем шаблон
   Set wdDoc = wdApp.Documents.Open(wordTemplatePath)
   wdApp.Visible = True ' Показать Word (для отладки)
   
   ' Устанавливаем альбомную ориентацию для всего документа
   With wdDoc.PageSetup
       .Orientation = 1 ' 1 = wdOrientLandscape (альбомная)
       .TopMargin = wdApp.CentimetersToPoints(1.5)
       .BottomMargin = wdApp.CentimetersToPoints(1.5)
       .LeftMargin = wdApp.CentimetersToPoints(1.5)
       .RightMargin = wdApp.CentimetersToPoints(1.5)
   End With
   
   ' Копируем таблицу из Excel
   rng.Copy
   
   ' Вставляем в Word
   With wdDoc
       ' Если используете закладку:
       If .Bookmarks.Exists("TablePlaceholder") Then
           .Bookmarks("TablePlaceholder").Select
           wdApp.Selection.PasteExcelTable False, False, False
       Else
           ' Иначе просто в конец документа
           .Content.InsertAfter vbCrLf
           .Content.Paste
       End If
       
       ' Настройка таблицы (последней в документе)
       Dim wdTable As Object
       Set wdTable = .Tables(.Tables.Count)
       
       With wdTable
           ' Автоподбор по ширине страницы
           .AutoFitBehavior 1 ' 1 = wdAutoFitWindow
           ' Включение переноса строк
           .AllowAutoFit = True
           ' Настройка шрифта (опционально)
           .Range.Font.Name = "Calibri"
           .Range.Font.Size = 9
       End With
       
       ' Сохраняем результат с уникальным именем
       .SaveAs outputPath & fileName
   End With
   
   ' Очистка объектов
   Set wdTable = Nothing
   Set wdDoc = Nothing
   Set wdApp = Nothing
   
   MsgBox "Данные успешно экспортированы в Word!" & vbCrLf & _
          "Файл сохранен как: " & fileName, vbInformation
End Sub
 
SMW, Доброго времени суток. Если я вас правильно понял то вам необходимо данный блок кода:
Код
' Настройка таблицы (последней в документе)
Dim wdTable As Object
Set wdTable = .Tables(.Tables.Count)

With wdTable
    ' Автоподбор по ширине страницы
    .AutoFitBehavior 1    ' 1 = wdAutoFitWindow
    ' Включение переноса строк
    .AllowAutoFit = True
    ' Настройка шрифта (опционально)
    .Range.Font.Name = "Calibri"
    .Range.Font.Size = 9
End With
Заменить на следуйщий блок:
Код
        ' Настройка таблицы (последней в документе)
        Dim wdTable As Object
        Set wdTable = .Tables(.Tables.Count)

        With wdTable
            
            ' Указываем первую строку как заголовок
            .Rows(1).HeadingFormat = True
            
            ' Автоподбор по ширине страницы
            .AutoFitBehavior 1    ' 1 = wdAutoFitWindow
            
            ' Включение переноса строк
            .AllowAutoFit = True
            
            ' Настройка шрифта (опционально)
            .Range.Font.Name = "Calibri"
            .Range.Font.Size = 9
        End With
Так-же:
Код
   Set rng = ws.Range("A1:M17") ' Укажите нужный диапазон
   Set rng = ws.Range("A18:M41")
   Set rng = ws.Range("A1:M100")
Замените на:
Код
    Set rng = ws.Range("A18:M" & ws.Range("A" & ws.Rows.Count).End(xlUp).Row)
И будет вам счастье, ;) Удачи.
Изменено: MikeVol - 13.05.2025 19:39:47 (Орфография...)
Страницы: 1
Читают тему
Наверх