Pergunte aqui

Histórico de revisões [voltar]

Após muita pesquisa consegui adaptar um código que atende a essa finalidade. Segue:

Para facilitar a execução do código, depois de pronto, você associa ele a um botão no word indo em Arquivo>opções>barra de ferramentas de acesso rápido> Escolher comando em:Macros e adicionar>>

Sub salvamaladireta()
Application.ScreenUpdating = False
Dim qtde As Integer
Dim nomeArquivo As String
Dim registro As Integer
Dim nomearquivouniorg As String


ActiveDocument.MailMerge.DataSource.ActiveRecord = wdFirstRecord

qtde = ActiveDocument.MailMerge.DataSource.RecordCount

For registro = 1 To qtde

nomeArquivo = ActiveDocument.MailMerge.DataSource.DataFields("NAME").Value 'no lugar de NAME voce colona o     nome da coluna da sua base de dados'
nomearquivouniorg = ActiveDocument.MailMerge.DataSource.DataFields("Uniorg").Value 'no luga de Uniorg voce colona     o nome da coluna da sua base de dados'

With ActiveDocument.MailMerge
    .Destination = wdSendToNewDocument
    .SuppressBlankLines = True
    With .DataSource
        .FirstRecord = ActiveDocument.MailMerge.DataSource.ActiveRecord
        .LastRecord = ActiveDocument.MailMerge.DataSource.ActiveRecord
    End With
    .Execute Pause:=False
End With
ActiveDocument.SaveAs2 FileName:="C:\Users\Thiago_2\Desktop\Example Merge Document\TERMO ADITIVO DE CONTRATO - " & nomearquivouniorg & " - " & " " & nomeArquivo & ".docx", FileFormat:= _
    wdFormatXMLDocument, LockComments:=False, Password:="", AddToRecentFiles _
    :=True, WritePassword:="", ReadOnlyRecommended:=False, EmbedTrueTypeFonts _
    :=False, SaveNativePictureFormat:=False, SaveFormsData:=False, _
    SaveAsAOCELetter:=False, CompatibilityMode:=15
    'O trecho C:\Users\Thiago_2\Desktop\Example Merge Document\TERMO ADITIVO DE CONTRATO - voce deve substituir pelo diretorio da sua pasta onde ira salvar os arquivos. A parte TERMO ADITIVO DE CONTRATO o inicio do nome do documento. Um inicio fixo que sera igual para todos'
ActiveWindow.Close
ActiveDocument.MailMerge.DataSource.ActiveRecord = wdNextRecord

Next registro
Application.ScreenUpdating = True
End Sub