Макрос для переноса таблицы excel в word

1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24

Sub ЭкспортВВОРД()
 
 
Dim adr As String
Dim copyTABL As Object
    
    adr = ActiveWorkbook.Path
 
ActiveWindow.SmallScroll Down:=27 
Range("A1:C39").Select
ActiveWindow.SmallScroll Down:=-39
Selection.Copy
 
Set oWord = CreateObject("Word.Application") 
    oWord.Visible = True
Set oDoc = oWord.Documents.Add()
    oDoc.Activate
    
    Selection.Paste 
    MyRange.Collapse Direction:=wdCollapseStart
    MyRange.Paste
   
 
End Sub

1
2
3
4
5
6

Range("A1:C39").Copy
With CreateObject("Word.Application").Documents.Add
     .Range.Paste '.Range.PasteExcelTable
     .Parent.Visible = True
End With
Application.CutCopyMode = False

1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30

Sub ÝêñïîðòÂÂîðä()
 
Dim adr As String
Dim AppWord As Object
Dim oDoc As Object
 
adr = ActiveWorkbook.Path
 
Range("A1:C39").Copy
 
Set AppWord = CreateObject("Word.Application")
AppWord.Visible = True
AppWord.Documents.Add
AppWord.Selection.Paste
AppWord.Activate
 
'ChangeFileOpenDirectory "adr"
    ActiveDocument.SaveAs Filename:="Îò÷åò î ïðîåçäå", FileFormat:= _
        wdFormatXMLDocument, LockComments:=False, Password:="", AddToRecentFiles _
        :=True, WritePassword:="", ReadOnlyRecommended:=False, EmbedTrueTypeFonts _
        :=False, SaveNativePictureFormat:=False, SaveFormsData:=False, _
        SaveAsAOCELetter:=False
    MsgBox ("Ôàéë ñîõðàíåí íà ðàáî÷èé ñòîë ïîä èìåíåì " & " '" & adr & " ' ")
 
 
    
 
Application.CutCopyMode = False
 
End Sub

1
2
3
4
5
6
7

Range("A1:C39").Copy
With CreateObject("Word.Application").Documents.Add
     .Range.PasteExcelTable False, False, True '.Range.Paste
     .SaveAs Filename:=ActiveWorkbook.Path & "Имя_документа.docx", FileFormat:=12 'wdFormatXMLDocument
     .Parent.Visible = True
End With
Application.CutCopyMode = False

1
2
3
4
5
6
7
8
9
10
11
12
13

Range("A1:C39").Copy
With CreateObject("Word.Application").Documents.Add
     .Range.Paste '.Range.PasteExcelTable False, False, True
     With .Tables(1)
          .Rows.HeightRule = 2 'wdRowHeightExactly
          For i = 1 To 39
              .Rows(i).Height = Rows(i).Height
          Next
     End With
     .SaveAs Filename:=ActiveWorkbook.Path & "Имя_документа.docx", FileFormat:=12 'wdFormatXMLDocument
     .Parent.Visible = True
End With
Application.CutCopyMode = False

1
2
3
4
5
6
7
8
9
10
11
12
13

Range("A1:C39").Copy
With CreateObject("Word.Application").Documents.Add
     .Range.Paste '.Range.PasteExcelTable False, False, True
     With .Tables(1)
          .Rows.HeightRule = 2 'wdRowHeightExactly
          For i = 1 To 39
              .Rows(i).Height = Rows(i).Height
          Next
     End With
     .SaveAs Filename:=ActiveWorkbook.Path & "Имя_документа.docx", FileFormat:=12 'wdFormatXMLDocument
     .Parent.Visible = True
End With
Application.CutCopyMode = False

1
2

With .Tables(1)
     .Range.Font.Name = "Times New Roman"