Gerar documentos individuais em word na mala direta.

 

O código abaixo gera documentos individuais, em docx, para cada um dos registros em um documento do Word com mala direta (Correspondência). O campo "Escola" deve existir na mala direta, pois será o nome do arquivo docx que será mesclado individualmente (apenas com os dados da referida linha). O nome da Macro sugerido é "exp". 

Sub exp()

    Dim docOrig As Document

    Dim docNovo As Document

    Dim campoEscola As String

    Dim i As Integer

    Dim pastaDestino As String

    

    ' Define o documento principal como o ativo

    Set docOrig = ActiveDocument

    ' Certifique-se de que há uma mala direta configurada

    If docOrig.MailMerge.DataSource.RecordCount = 0 Then

        MsgBox "Nenhum registro encontrado na mala direta.", vbExclamation, "Erro"

        Exit Sub

    End If

    ' Define a pasta onde os arquivos serão salvos

    pastaDestino = docOrig.Path

    If pastaDestino = "" Then pastaDestino = Environ("USERPROFILE") & "\Documents"

    ' Percorre todos os registros da mala direta

    With docOrig.MailMerge

        For i = 1 To .DataSource.RecordCount

            ' Define o registro atual para a mala direta

            .DataSource.ActiveRecord = i

            

            ' Obtém o valor do campo "Escola"

            campoEscola = Trim(.DataSource.DataFields("Escola").Value)

            ' Substitui caracteres inválidos para nomes de arquivos

            campoEscola = Replace(campoEscola, "/", "-")

            campoEscola = Replace(campoEscola, "\", "-")

            campoEscola = Replace(campoEscola, ":", "-")

            campoEscola = Replace(campoEscola, "*", "-")

            campoEscola = Replace(campoEscola, "?", "-")

            campoEscola = Replace(campoEscola, """", "-")

            campoEscola = Replace(campoEscola, "<", "-")

            campoEscola = Replace(campoEscola, ">", "-")

            campoEscola = Replace(campoEscola, "|", "-")

            ' Verifica se o campo não está vazio

            If campoEscola <> "" Then

                ' Cria uma cópia do documento original apenas para o registro atual

                docOrig.Range.Copy

                ' Cria um novo documento e cola o conteúdo da cópia

                Set docNovo = Documents.Add

                docNovo.Range.Paste

                

                ' Salva o novo documento com o nome da Escola

                docNovo.SaveAs2 FileName:=pastaDestino & "\" & campoEscola & ".docx", FileFormat:=wdFormatDocumentDefault

                

                ' Fecha o novo documento

                docNovo.Close False

            End If

        Next i

    End With

    MsgBox "Documentos exportados com sucesso! Verifique a pasta: " & pastaDestino, vbInformation, "Concluído"

End Sub