Creare tanti File PDF con stampa unione di Word su base dati in Excel.

Question

Buongiorno a tutti gli amici della community.

Devo predisporre tanti file pdf da un elenco di Excel che ha 215 colonne di dati.

Chiedo il vostro competente e prezioso aiuto per poter  creare i File Pdf e salvarli in una determinata cartella prendendo come nome dei vari file i dati di 3 campi che si chiamano Matricola; Grado e Cognome e Nome.

Inoltre desidero che i file PDF riportino pure la data e l'ora di salvataggio.

Ringrazio anticipatamente per l'aiuto fornito.

Ciao Nicola.

Answer 1

Ciao Nicola,

Si può già vedere un elenco sequenziale dei nomi dei file pdf, mentre vengono salvati, sulla barra di stato di Word.

Nel caso di grandi quantità di file, di peso multi-megabte, Word fornisce una barra di avanzamento integrato. Io ho provato il mio codice per salvare 50 file, ognuno di 8.5MB, caricati con  50 colonne x 2000 righe di numeri casuali, e sono stato ricompensato con la seguente barra di avanzamento:

Per ricevere un rapporto di MsgBox al termine dell'operazione di stampa  richiede solo un paio di righe in più di codice; sostituisci le righe:

        Next i

    End With

con:

        Next i

    End With

    Call MsgBox(Prompt:="Ci sono stati salvati " _

                      & i & " file pdf", _

                Buttons:=vbInformation, _

                Title:="FINITO")

===

Regards,

Norman

Answer 2

Ciao Nicola,

Ho scaricato i tuoi due file.

Io non avevo capito che volevi  utilizzare MailMerge per creare i file pdf. Comunque se questo sia il tuo obiettivo, non mi pare che tu abbia creato un documento MailMerge.  Pertanto, per provare il codice, ho creato un documento mailMerge banale:

Ho poi modificato il codice dell'altro thread di Barbara per gestire le tue esigenze. Quindi, nel modulo1 del tuo file Word, ho sostituito il tuo codice  con la seguente versione:

'=========>>

Option Explicit

'--------->>

Public Sub Tester()

    Dim MyDoc As Document

    Dim sStr As String, sName As String, sPath As String

    Dim i As Long, j As Long

    Const sPercorsoDestinazione As String = _

                                       "C:\Users\Nicola"                      '<<=== Modifica

    On Error GoTo ErrHandler

    With Application

        sStr = .PathSeparator

        .ScreenUpdating = False

    End With

    If Right(sPercorsoDestinazione, 1) = sStr Then

        sPath = sPercorsoDestinazione

    Else

        sPath = sPercorsoDestinazione & sStr

    End If

    Set MyDoc = ThisDocument

    With MyDoc

        For i = 1 To .MailMerge.DataSource.RecordCount

            With .MailMerge

                .Destination = wdSendToNewDocument

                .SuppressBlankLines = True

                With .DataSource

                    .FirstRecord = i

                    .LastRecord = i

                    .ActiveRecord = i

                    If Trim(.DataFields("Matricola")) = "" Then

                        Exit For

                    End If

                    sName = .DataFields("Matricola") _

                          & "_" _

                          & .DataFields("Grado") _

                          & "_" _

                          & .DataFields("Cognome_e_Nome") _

                          & Format(Now, "yyyymmdd hh-mm")

                End With

                .Execute Pause:=False

            End With

            For j = 1 To 255

                Select Case j

                Case 1 To 31, 33, 34, 37, 42, 44, 46, 47, _

                     58 - 63, 91 - 93, 96, 124, 147, 148

                    sName = Replace(sName, Chr(j), "")

                End Select

            Next

            sName = Trim(sName)

            With ActiveDocument

                .SaveAs FileName:=sPath & sName & ".pdf", _

                        FileFormat:=wdFormatPDF, _

                        AddToRecentFiles:=False

                .Close SaveChanges:=False

            End With

        Next i

    End With

XIT:

    On Error GoTo 0

    Application.ScreenUpdating = True

    Exit Sub

ErrHandler:

    Call MsgBox(Prompt:=Err.Description & " " & Err.Number, _

                Buttons:=vbCritical, _

                Title:="Errore")

    Resume XIT

End Sub

'<<=========

Nota anche che, prima di creare il documento MailMerge, ho cancellato uno spazio finale nella intestazione Cognome e Nome nella cella B1 su Foglio1 del tuo file Excel.

Eseguendo questo codice, nella directory C:\users\Nicola, ho ottenuto i seguenti nove file pdf:

Noterai che, come richiesto questi file hanno una struttura di nome del tipo:

Matricola + Grado + Cognome e Nome + data e l'ora di salvataggio.

I file pdf salvati sono della forma:

Ovviamente, sarà necessario adattare il documento di unione in accordo con le tue esigenze, ma il codice dovrebbe funzionare indipendentemente dal layout del documento finale.

Potresti scaricare i miei file di prova Nicola20150901.docm e Nicola#2_20150901.xlsm a:   http://1drv.ms/1VuWk5c

===

Regards,

Norman

Answer 3

Ciao Nicola,

L'errore che hai riscontrato suggerirebbe che non ci siano stati trovati alcuni dati nella colonna A del Foglio1 del tuo file. Potresti postare un immagine delle prime dieci righe del tuo foglio e verificare che il suo nome sia Foglio1?

Nel frattempo, potresti scaricare il mio file di prova Nicola20150901.xlsm, il quale è basato su un vecchio file tuo, a:

                                     **http://1drv.ms/1hunA4A**

Nota, che nel file caricato. per rendere visibile all'utente il progresso della procedura sulla barra di stato, nel codice, ho sostituito la riga:

        sFileName = sPath & aStr & ".pdf"

con:

        sFileName = sPath & aStr & ".pdf"

        Application.StatusBar = "Record " & i & " di " & UBound(arrIn, 1)

e la riga

    Next i

con:

    Next i

    Application.StatusBar = False

===

Regards,

Norman

Answer 4

Ciao Norman innanzitutto grazie per il tuo gentile e prezioso intervento.

Il codice mi va in errore qui: arrIn = Rng.Value

Ti posto sia l'immagine dell'errore che il codice che ho adattato alle mie colonne e al mio foglio di Excel.

 Const sPercorsoDestinazione As String = _

                                        "C:\Users\NIcola\Desktop\Nuova cartella"                    '<<===== Modifica

     Const PrimaRigaDati As Long = 2                          '<<===== Modifica

     Const colMatricola As String = "B"                             '<<===== Modifica

     Const colGrado As String = "C"                                   '<<===== Modifica

     Const colNomeCognome As String = "D"                  '<<===== Modifica

     Const sNomeFoglio As String = " Foglio1"         

Ti ringrazio e ti saluto.

Ciao Nicola

Answer 5

Ciao Nicola,

Prova qualcosa del genere:

'=========>>

Option Explicit

'--------->>

Public Sub Tester()

    Dim WB As Workbook

    Dim SH As Worksheet

    Dim Rng As Range, rCell As Range

    Dim arrIn As Variant

    Dim aStr As String, sStr As String

    Dim sPath As String, sFileName As String

    Dim LRow As Long

    Dim i As Long, x As Long, y As Long, z As Long

    Const sPercorsoDestinazione As String = _

                                       "C:\Users\Nicola"                    '<<===== Modifica

    Const PrimaRigaDati As Long = 10 '<<===== Modifica

    Const colMatricola As String = "B"                             '<<===== Modifica

    Const colGrado As String = "C"                                   '<<===== Modifica

    Const colNomeCognome As String = "D"                 '<<===== Modifica

    Const sNomeFoglio As String = "Foglio1"          <<===== Modifica

    Set WB = ActiveWorkbook

    Set SH = WB.Sheets(sNomeFoglio)

    sStr = Application.PathSeparator

    If Right(sPercorsoDestinazione, 1) = sStr Then

        sPath = sPercorsoDestinazione

    Else

        sPath = sPercorsoDestinazione & sStr

    End If

    With SH

        LRow = LastRow(SH, .Columns("A:A"))

        Set Rng = .Range("A" & PrimaRigaDati _

                       & ":" & colNomeCognome & LRow)

        x = .Columns(colMatricola).Column

        y = .Columns(colGrado).Column

        z = .Columns(colNomeCognome).Column

    End With

    arrIn = Rng.Value

    For i = LBound(arrIn, 1) To UBound(arrIn, 1)

        aStr = arrIn(i, x) _

             & "_" _

             & arrIn(i, y) _

             & "_" _

             & arrIn(i, z) _

             & "_" _

             & Format(Now, "yyyymmdd hh-mm")

        sFileName = sPath & aStr & ".pdf"

        Debug.Print sFileName

        SH.ExportAsFixedFormat _

                Type:=xlTypePDF, _

                Filename:=sFileName, _

                Quality:=xlQualityStandard, _

                IncludeDocProperties:=True, _

                IgnorePrintAreas:=False, _

                OpenAfterPublish:=False

    Next i

    Call MsgBox(Prompt:="Finito", _

                Buttons:=vbInformation, _

                Title:="Un altro giorno, un altro dollaro!")

End Sub

'--------->>

Public Function LastRow(SH As Worksheet, _

                        Optional Rng As Range)

    If Rng Is Nothing Then

        Set Rng = SH.Cells

    End If

    On Error Resume Next

    LastRow = Rng.Find(What:="*", _

                       after:=Rng.Cells(1), _

                       Lookat:=xlPart, _

                       LookIn:=xlFormulas, _

                       SearchOrder:=xlByRows, _

                       SearchDirection:=xlPrevious, _

                       MatchCase:=False).Row

    On Error GoTo 0

End Function

'<<=========

===

Regards,

Norman