Добрый день!
Нужна помощь в корректировки макроса.
У меня есть таблица эксель с данными, куда добавлен макрос на выгрузку данных с определенного листа.
Необходимо, чтобы по диапазону таблицы 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
Нужна помощь в корректировки макроса.
У меня есть таблица эксель с данными, куда добавлен макрос на выгрузку данных с определенного листа.
Необходимо, чтобы по диапазону таблицы 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