Excel Excel copia e cola no Word com linhas formatadas

[Luciana Goes]

Olá!

Estou aqui novamente para pedir uma nova ajuda.

Tenho uma planilha que executa uma macro que copia as células do Excel e cola no Word como tabela. (O arquivo fica salvo na área de trabalho). Até aí a macro está feita e funcionando perfeitamente.

O que preciso é que, assim que copiar pro Word, a macro formate as linhas pra ficarem ajustadas e não muito espaçadas (seria uma formatação de parágrafo). 

Rodei a macro direto no word e colei o código abaixo. A minha dificuldade é fazer com que o Excel entenda este código.

Será que alguém pode me ajudar? Segue o arquivo anexo. 

 

Selection.WholeStory
    With Selection.ParagraphFormat
        .LeftIndent = CentimetersToPoints(0)
        .RightIndent = CentimetersToPoints(0)
        .SpaceBefore = 0
        .SpaceBeforeAuto = False
        .SpaceAfter = 0
        .SpaceAfterAuto = False
        .LineSpacingRule = wdLineSpaceSingle
        .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

Formatar linha no Word.zip

[Basole]

@Luciana Goes segue o código com as alterações, com a altura da linha para 0,46 cm

 

 

Sub Formatarlinhaword()
Dim caminho As String
Dim nome As String
Range("B2:B6").Copy
Range("D2").Value = Environ("USERPROFILE")
caminho = Range("d3").Value
nome = Range("d4").Value
Set wrdApp = CreateObject("Word.Application")
wrdApp.Visible = True
Set wrddoc = wrdApp.Documents.Add
With wrddoc
.Activate
.Range.Paste
       With .Tables(.Tables.Count)
        '.AutoFitBehavior wdAutoFitWindow
        .Rows.SetHeight RowHeight:=wrddoc.Application.CentimetersToPoints(0.46), _
                        HeightRule:=wdRowHeightExactly  'Ajusta Altura da linha
       End With
    
Selection.Cells.Merge


If Dir(caminho & nome) <> "" Then
Kill caminho & nome
End If
.SaveAs (caminho & nome)
.Application.Quit
End With
Set wrddoc = Nothing
Set wrdApp = Nothing
Application.CutCopyMode = False
Set wrddoc = Nothing
Set wrdApp = Nothing
Application.CutCopyMode = False
Range("b3").Select
End Sub

 

*  Marque a referencia "Microsoft Word xx.x Object Library"  na sua planilha do Excel

 

 

[Luciana Goes]

Deu certo!
Muito obrigada!!!