Sub gerarpdf()

Dim a As Integer

Dim teste As String

Dim registro As Integer

Dim nomeArquivo As String

Dim nomeEscola As String

Dim f As Integer

Dim ate As Integer


'Define o primeiro registro da mala direta

ActiveDocument.MailMerge.DataSource.ActiveRecord = wdFirstRecord

'Contador de registros

a = ActiveDocument.MailMerge.DataSource.RecordCount

'Exporta todos os registros
For registro = 1 To 5

    'Atribui o valor de cada registro da coluna nome para a variável nomeArquivo que dará nome ao novo arquivo. Caso queira outro nome, basta colocar o nome da coluna desejada
    nomeArquivo = ActiveDocument.MailMerge.DataSource.DataFields("ESCOLA").Value
    nomeEscola = ActiveDocument.MailMerge.DataSource.DataFields("ESCOLA").Value
    'prepara o nome do arquivo tirando caracteres especiais
    teste = Acento(nomeArquivo)
    f = registro
    Do While nomeArquivo = nomeEscola
    ' cria o arquivo pdf
        ate = registro
        ActiveDocument.MailMerge.DataSource.ActiveRecord = wdNextRecord
        nomeEscola = ActiveDocument.MailMerge.DataSource.DataFields("ESCOLA").Value
        registro = registro + 1
    Loop

        ActiveDocument.ExportAsFixedFormat2 OutputFileName:= _
        "C:UsersrepraDesktopgabarito_" & teste & ".pdf" _
        , ExportFormat:=wdExportFormatPDF, OpenAfterExport:=False, OptimizeFor:= _
        wdExportOptimizeForPrint, Range:=wdExportFromTo, From:=1, To:=5, _
        Item:=wdExportDocumentContent, IncludeDocProps:=True, KeepIRM:=True, _
        CreateBookmarks:=wdExportCreateNoBookmarks, DocStructureTags:=True, _
        BitmapMissingFonts:=True, UseISO19005_1:=False

    Next registro
    End Sub
Function Acento(caract)

    'caracteres especiais
    codiA = "-/àáâãäèéêëìíîïòóôõöùúûüÀÁÂÃÄÈÉÊËÌÍÎÒÓÔÕÖÙÚÛÜçÇñÑ"

    'Letras correspondentes para substituição
    codiB = "_ aaaaaeeeeiiiiooooouuuuAAAAAEEEEIIIOOOOOUUUUcCnN"

    temp = caract

    'Loop que irá de andará a string letra a letra
    For i = 1 To Len(temp)

        'InStr buscará se a letra indice i de temp pertence a
        ' codiA e se existir retornará a posição dela
        p = InStr(codiA, Mid(temp, i, 1))

        'Substitui a letra de indice i em codiA pela sua
        ' correspondente em codiB
        If p > 0 Then Mid(temp, i, 1) = Mid(codiB, p, 1)
    Next

    'Retorna a nova string
    Acento = temp

End Function