Option Explicit

' =============================================================================
' копирование таблицы с первого листа данной книги в новый документ word
' обработка примера http://www.sql.ru/forum/actualutils.aspx?action=gotomsg&tid=971576&msg=13214591
Sub copypast()
'баг1: таблица получается не на всю ширину страницы :(
'баг2: после вставки word, собако, подбирает ширину столбцов "по содержимому"
'
    Const wdCollapseStart = 1, wdCollapseEnd = 0
    
    Dim wd As Object, doc As Object
    Dim iTmpRow As Long, s As String
    
    'создать объект word, добавить новый документ
    Set wd = CreateObject("word.application")
    Set doc = wd.documents.Add
    
    With ThisWorkbook.Worksheets(1)
        With .PageSetup
            ' *** размер страницы
            ' (!) будет работать только для форматов А3,А4
            ' (!) для остальных форматов не проверял соответствие вордовских и экселевских констант
            'xlPaperA4= 9 wdPaperA4= 7
            'xlPaperA3= 8 wdPaperA3= 6
            doc.PageSetup.PaperSize = .PaperSize - 2
            
            ' *** ориентация страницы
            'xlLandscape= 2 wdOrientLandscape= 1
            'xlPortrait=  1  wdOrientPortrait= 0
            doc.PageSetup.Orientation = .Orientation - 1
            
            ' *** поля
            doc.PageSetup.TopMargin = .TopMargin
            doc.PageSetup.BottomMargin = .BottomMargin
            doc.PageSetup.LeftMargin = .LeftMargin
            doc.PageSetup.RightMargin = .RightMargin
            
            ' *** сквозная *строка*
            ' (!) не строкИ, т.к. WORD не даст задать более одной строки в качестве заголовка
            ' (!) таблицы, если в последней есть вертикальное объединение ячеек
            '
            '    если .PrintTitleRows = "" то сквозных строк нет
            s = .PrintTitleRows
            
        End With '.PageSetup
        
        With .UsedRange
            If Len(s) > 0 Then iTmpRow = .Range(s).Row
            
            If iTmpRow > 1 Then
                'добавляем абзац в начало документа (позже пригодится)
                wd.Selection.InsertParagraphBefore
                wd.Selection.collapse wdCollapseEnd
            Else
                iTmpRow = 1
            End If
                
            'копипастим часть экселевской таблицы от "сквозной" строки до конца
            .Rows(iTmpRow & ":" & .Rows.Count).Copy
            wd.Selection.PasteExcelTable False, False, False
            
            'если в экселевской таблице есть "сквозные" строки
            'назначить первую строку вордовской таблицы её "шапкой"
            If Len(s) > 0 Then
'баг3       ' *непонятно*
            ' если устанавливать это свойство программно - не рисует шапку
            ' на каждой странице, хотя в юзерфейсе ворда флажок <Заголовки>
            ' для данной таблицы устанавливается
                doc.tables(1).Rows.HeadingFormat = True
            End If
            
            ' если "сквозная" строка в экселевской таблице не первая
            If iTmpRow > 1 Then
                'смещаем Selection в начало документа
                wd.Selection.Start = 0
                wd.Selection.collapse wdCollapseStart
            
                'копипастим "шапку" экселевской таблицы (от начала до "сквозной строки")
                .Rows("1:" & (iTmpRow - 1)).Copy
                wd.Selection.PasteExcelTable False, False, False
                
                'уменьшпем величину шрифта "буферного" абзаца
                wd.Selection.Font.Size = 1
            End If
                
        End With '.UsedRange
    End With 'ThisWorkbook.Worksheets(1)
    
    'освободить буфер обмена
    Application.CutCopyMode = False
    
    
    Set doc = Nothing
    wd.Visible = True
    Set wd = Nothing

End Sub