Sub copy()
     
    
     Dim wdApp As New Word.Application 
     Dim wdDoc As Word.Document 

     wdApp.Visible = True 
     Set wdDoc = wdApp.Documents.Add 
     wdDoc.PageSetup.Orientation = wdOrientPortrait 
     
     With wdDoc.Paragraphs.Format
               .RightIndent = CentimetersToPoints(0)
               .SpaceBefore = 0
               .SpaceBeforeAuto = False
               .SpaceAfter = 0
               .SpaceAfterAuto = False
               .LineSpacingRule = wdLineSpaceSingle
               .Alignment = wdAlignParagraphLeft
               .WidowControl = True
               .KeepWithNext = False
               .KeepTogether = False
               .PageBreakBefore = False
               .NoLineNumber = False
               .Hyphenation = True
               .FirstLineIndent = CentimetersToPoints(0)
               .OutlineLevel = wdOutlineLevelBodyText
               .CharacterUnitLeftIndent = 0
               .CharacterUnitRightIndent = 0
               .CharacterUnitFirstLineIndent = 0
               .LineUnitBefore = 0
               .LineUnitAfter = 0
               .MirrorIndents = False
               .TextboxTightWrap = wdTightNone
     End With
     
     Application.Selection.copy 
     Call wdDoc.Range.Paste 
         
   
     With wdDoc.Tables(1)
        .AutoFitBehavior (wdAutoFitWindow)
        .AutoFitBehavior (wdAutoFitWindow)
        .Rows.HeightRule = wdRowHeightAtLeast
        .Rows.Height = CentimetersToPoints(0.4)
        .Cells.VerticalAlignment = wdCellAlignVerticalCenter
     End With
     Application.CutCopyMode = False 
     wdApp.Activate 
End Sub