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
