Código VBA para gerar relatórios a partir de mala direta

[Fernanda Marques de Araujo]

Olá. 

Eu gostaria de ajuda com um código VBA.

Há uns 2 anos atrás encontrei o código abaixo em um fórum na internet. Trata-se de um comando para gerar relatórios  a partir de mala direta (um relatório para cada linha da planilha Excel)

Eu executava esse código no WORD e ele gerava todos os relatórios a partir do meu modelo. Porém, atualmente está dando o seguinte erro ao executar: [Erro em tempo de Execução '5941': o membro solicitado da coleção não existe]

Alguém sabe como corrigir esse erro? ou então conhece algum outro código que atenda ao que eu preciso?

Obs: tenho muito pouco conhecimento em programação. HELP-ME

 

Código VBA:

Sub Laudos_Queimadas()
'
' Laudos_Queimadas
'
'
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("A").Value
nomearquivouniorg = ActiveDocument.MailMerge.DataSource.DataFields("A").Value

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:="\\SRV-1383\estagiarios\TAREFAS_SAJ\QUEIMADAS\2024\IDs\LAUDOS\Laudo_nXXX_24_Pantanal_em_Alerta_ID_" & nomearquivouniorg & ".docx", FileFormat:= _
    wdFormatXMLDocument, LockComments:=False, Password:="", AddToRecentFiles _
    :=True, WritePassword:="", ReadOnlyRecommended:=False, EmbedTrueTypeFonts _
    :=False, SaveNativePictureFormat:=False, SaveFormsData:=False, _
    SaveAsAOCELetter:=False, CompatibilityMode:=15
   
ActiveWindow.Close
ActiveDocument.MailMerge.DataSource.ActiveRecord = wdNextRecord

Next registro
Application.ScreenUpdating = True
End Sub

[Fernanda Marques de Araujo]

Consegui configurar um código que gera todos os relatórios individuais (pedi ajuda ao chat GPT)

Sub SalvaDocumentosIndividuais()
    Const Caminho = "\\SRV-1383\estagiarios\TAREFAS_SAJ\QUEIMADAS\2024\LAUDOS\"
    Dim MainDoc As Document
    Dim NovoDoc As Document
    Dim i As Long
    Dim NomeArquivo As String
    Dim Identificador As String

    ' Definir o documento principal
    Set MainDoc = ActiveDocument

    ' Executar a mala direta para cada registro da fonte de dados
    For i = 2 To MainDoc.MailMerge.DataSource.recordCount
        ' Mover para o registro específico
        MainDoc.MailMerge.DataSource.ActiveRecord = i

        ' Obter o valor da coluna "A" (assumindo que é a primeira coluna)
        Identificador = MainDoc.MailMerge.DataSource.DataFields(1).Value

        With MainDoc.MailMerge
            .Destination = wdSendToNewDocument
            .SuppressBlankLines = True
            .DataSource.FirstRecord = i
            .DataSource.LastRecord = i
            .Execute Pause:=False
        End With

        ' Definir o nome do arquivo
        NomeArquivo = Caminho & "Laudo_nXXX_24_Pantanal_em_Alerta_ID-" & Identificador & ".docx"

        ' Salvar o documento como .docx
        Set NovoDoc = ActiveDocument
        NovoDoc.SaveAs2 fileName:=NomeArquivo, FileFormat:=wdFormatXMLDocument
        NovoDoc.Close False

        ' Limpar a referência ao novo documento
        Set NovoDoc = Nothing
    Next i

    ' Limpar a referência ao documento principal
    Set MainDoc = Nothing

    MsgBox "Documentos salvos com sucesso!"
End Sub