Risolto Stampa unione singoli file pdf

Eymerich

Utente junior
3 Aprile 2020
34
8
Excel 2016
2
Buona sera a tutti!
Tempo fa trovai qui la soluzione al problema, come da oggetto, di salvare ogni stampa unione in singoli pdf.

Visual Basic:
       Sub StampaUnioneSingoli_FILE()
'
' StampaUnioneSingoli FILE nel formato desiderato (docx, rtf o PDF) Macro (di default è docx)
'
'
On Error GoTo ErrH
Dim objWdMailMerge As Word.MailMerge
Dim lngRecNum As Long
Dim strPath As String
Dim strFilename As String

Application.ScreenUpdating = False

'NOTA: AL POSTO DI "C:\STAMPE" METTERE LA DIRECTORY DI APPOGGIO CHE VOGLIAMO
strPath = "C:\STAMPE\"

Set objWdMailMerge = ThisDocument.MailMerge
With objWdMailMerge
.Destination = wdSendToNewDocument
With .DataSource
.ActiveRecord = wdLastRecord
lngRecNum = .ActiveRecord
.ActiveRecord = wdFirstRecord
Do
.FirstRecord = .ActiveRecord
.LastRecord = .ActiveRecord
'NOTA: AL POSTO DI "Proponente" può essere utilizzato uno qualunque dei campi del file excel con cui si fa il merge, fare attenzione che vi sia corrispoindeza tra tutti i campi utilizzati in Word e i campi del foglio Excel, altrimenti la macro non funziona
strFilename = .DataFields("Proponente").Value
If Len(strFilename) Then
' NOTA: A SECONDA DEL TESTO CHE SI VUOLE INSERIRE DOPO IL NOME DEL PROPONENTE, CAMBIARE LA PARTE TRA LE VIRGOLETTE ("_DECRETO")
strFilename = strPath & strFilename & "_Decreto"
objWdMailMerge.Execute
With ActiveDocument
' NOTA: A SECONDA DEL FORMATO CHE DOBBIAMO GENERARE TOGLIERE L'APICE DI IDENTIFICAZIONE COMMENTO DALLA RIGA INTERESSATA
.SaveAs strFilename, wdFormatdoc, AddToRecentFiles:=False
' .SaveAs strFilename, wdFormatRTF, AddToRecentFiles:=False
' .SaveAs strFilename, wdFormatPDF, AddToRecentFiles:=False
.Saved = True
.Close
End With
End If
If .ActiveRecord = lngRecNum Then Exit Do
.ActiveRecord = wdNextRecord
Loop
End With
End With

ExitProc:
Application.ScreenUpdating = True
Set objWdMailMerge = Nothing
Exit Sub

ErrH:
MsgBox Err.Description
Resume ExitProc

End Sub
Ora il Problema è che se nella lista excel ho dei nomi ripetuti mi fa la stampa pdf di un record solo ignorando gli altri.
fare in modo che mi salvi i file con il (1) (2) ecc è possibile?
tipo
Nome (1).pdf
Nome (2).pdf
Nome (3).pdf

Grazie!
 

Eymerich

Utente junior
3 Aprile 2020
34
8
Excel 2016
2
Stavo pensando che potrebbe mettere nel nome file un contatore progressivo per ogni file
1 file
2 file
3 flie
...
È possibile?!
Purtroppo VB è ancora molto oscuro per me.
Grazie.

Luca
 

Rubik72

Excel/VBA Expert
Supermoderatore
12 Dicembre 2015
9.468
345
48
Cosenza
Excel 2016
655
prova ad integrare la tua routine con queste righe di codice:
Visual Basic:
[...]
            fName = .DataFields("Proponente").Value 'assegna il nome del campo ad una variabile
            FileName = Dir(strPath & fName) 'identifica tramite la funzione Dir se il file esiste gia'
            Count = 1 'azzera la variabile da associare al nome del file
            Do While FileName <> "" 'esegue un ciclo fino a non trovare piu' files
               Count = Count + 1 'aumenta il contatore
               FileName = Dir() 'riesegue la verifica se ne esistono altri
            Loop
            strFilename = .DataFields("Proponente").Value & " " & Count 'assegna alla variabile il nome del campo con il contatore
[...]
N.B. non ho eseguito test (scritto a memoria e potrebbero esserci errori) in quanto non hai allegato file di esempio di Excel e Word che è sempre buona norma allegare. :scoppola:
 

Eymerich

Utente junior
3 Aprile 2020
34
8
Excel 2016
2
Scuami:arrossisco:, non conoscendo niente di VB, pensavo bastasse condividere il codice, ora faccio un file excel e un file word da allegare come esempio.
Altro problema è che non saprei proprio dove integrare il tuo pezzo di codice :studia:
 

Rubik72

Excel/VBA Expert
Supermoderatore
12 Dicembre 2015
9.468
345
48
Cosenza
Excel 2016
655
Eccco la routine intera
Visual Basic:
Sub StampaUnioneSingoli_FILE()
'
' StampaUnioneSingoli FILE nel formato desiderato (docx, rtf o PDF) Macro (di default è docx)
'
'
On Error GoTo ErrH
Dim objWdMailMerge As Word.MailMerge
Dim lngRecNum As Long
Dim strPath As String
Dim strFilename As String

Application.ScreenUpdating = False

'NOTA: AL POSTO DI "C:\STAMPE" METTERE LA DIRECTORY DI APPOGGIO CHE VOGLIAMO
strPath = "C:\STAMPE\"

Set objWdMailMerge = ThisDocument.MailMerge
With objWdMailMerge
    .Destination = wdSendToNewDocument
    With .DataSource
        .ActiveRecord = wdLastRecord
        lngRecNum = .ActiveRecord
        .ActiveRecord = wdFirstRecord
        Do
            .FirstRecord = .ActiveRecord
            .LastRecord = .ActiveRecord
            strFilename = .DataFields("Nome").Value
            If Len(strFilename) Then

                FName = .DataFields("Nome").Value 'assegna il nome del campo ad una variabile
                FileName = Dir(strPath & FName) 'identifica tramite la funzione Dir se il file esiste gia'
                Count = 1 'azzera la variabile da associare al nome del file
                Do While FileName <> "" 'esegue un ciclo fino a non trovare piu' files
                   Count = Count + 1 'aumenta il contatore
                   FileName = Dir() 'riesegue la verifica se ne esistono altri
                Loop
                strFilename = .DataFields("Nome").Value & " " & Count 'assegna alla variabile il nome del campo con il contatore
               
                objWdMailMerge.Execute
                With ActiveDocument
                    ' NOTA: A SECONDA DEL FORMATO CHE DOBBIAMO GENERARE TOGLIERE L'APICE DI IDENTIFICAZIONE COMMENTO DALLA RIGA INTERESSATA
                    .SaveAs strPath & strFilename, wdFormatdoc, AddToRecentFiles:=False
                    ' .SaveAs strFilename, wdFormatRTF, AddToRecentFiles:=False
                    ' .SaveAs strFilename, wdFormatPDF, AddToRecentFiles:=False
                    .Saved = True
                    .Close
                End With
            End If
            If .ActiveRecord = lngRecNum Then Exit Do
            .ActiveRecord = wdNextRecord
        Loop
    End With
End With

ExitProc:
Application.ScreenUpdating = True
Set objWdMailMerge = Nothing
Exit Sub

ErrH:
MsgBox Err.Description
Resume ExitProc

End Sub
 

Eymerich

Utente junior
3 Aprile 2020
34
8
Excel 2016
2
Sarò io che faccio casino, ma non funziona, si stampa pdf, ma se son doppi, ne salva solo uno.
Stavo pensando che forse per rendere la faccenda più semplice si può aggiungere al nome il campo della data,
ma ovviamente non saprei dove mettere le mani, delle prove le ho fatte, ma mi va in errore.
Non so se serva come informazione.
Per importare la Data associata,
ho aggiunto codice di campo {MERGEFIELD Data \@ "DD/MM/YYYY"}
dato che, anche se nell'excel le date siano disposte così, nel word me le importa all'americana.

Grazie per la pazienza.

Luca
 

Eymerich

Utente junior
3 Aprile 2020
34
8
Excel 2016
2
Visual Basic:
Sub StampaUnioneSingoli_PDF()
'
' StampaUnioneSingoli FILE nel formato desiderato (docx, rtf o PDF) Macro (di default è docx)
'
'
On Error GoTo ErrH
Dim objWdMailMerge  As Word.MailMerge
Dim lngRecNum       As Long
Dim strPath         As String
Dim strFilename     As String
 
    Application.ScreenUpdating = False
 
'NOTA: AL POSTO DI "C:\STAMPE" METTERE LA DIRECTORY DI APPOGGIO CHE VOGLIAMO
    strPath = "C:\Stampe"
 
    Set objWdMailMerge = ThisDocument.MailMerge
    With objWdMailMerge
      .Destination = wdSendToNewDocument
      With .DataSource
        .ActiveRecord = wdLastRecord
        lngRecNum = .ActiveRecord
        .ActiveRecord = wdFirstRecord
        Count = 1
        Do
          .FirstRecord = .ActiveRecord
          .LastRecord = .ActiveRecord
'NOTA: AL POSTO DI "Proponente" può essere utilizzato uno qualunque dei campi del file excel con cui si fa il merge, fare attenzione che vi sia corrispoindeza tra tutti i campi utilizzati in Word e i campi del foglio Excel, altrimenti la macro non funziona
          strFilename = .DataFields("Nome").Value & " " & Count
          If Len(strFilename) Then
' NOTA: A SECONDA DEL TESTO CHE SI VUOLE INSERIRE DOPO IL NOME DEL PROPONENTE, CAMBIARE LA PARTE TRA LE VIRGOLETTE ("_DECRETO")
            strFilename = strPath & strFilename & "_Testo"
            objWdMailMerge.Execute
            With ActiveDocument
' NOTA: A SECONDA DEL FORMATO CHE DOBBIAMO GENERARE TOGLIERE L'APICE DI IDENTIFICAZIONE COMMENTO DALLA RIGA INTERESSATA
             ' .SaveAs strFilename, wdFormatdoc, AddToRecentFiles:=False
             ' .SaveAs strFilename, wdFormatRTF, AddToRecentFiles:=False
              .SaveAs strFilename, wdFormatPDF, AddToRecentFiles:=False
              .Saved = True
              Count = Count + 1 'aumenta il contatore
              .Close
            End With
          End If
          If .ActiveRecord = lngRecNum Then Exit Do
          .ActiveRecord = wdNextRecord
        Loop
      End With
    End With
 
ExitProc:
    Application.ScreenUpdating = True
    Set objWdMailMerge = Nothing
    Exit Sub
 
ErrH:
    MsgBox Err.Description
    Resume ExitProc
 
End Sub
Guardando i codici che mi ha proposto, ho trovato una via di fuga, non è la soluzione, ma adesso stampa tutti.
Ho usato il contatore e mi numera le stampe. Non posso ancora crederci di aver capito il codice e di aver inserito il contatore in maniera corretta o per lo meno, non so se sia corretta, ma funziona:felice:

Si trovasse il metodo con la data sarebbe bello:studia:, comunque già così va benone.

GRAZIE!

Luca
 
  • Like
Reactions: Rubik72

Rubik72

Excel/VBA Expert
Supermoderatore
12 Dicembre 2015
9.468
345
48
Cosenza
Excel 2016
655
Sarò io che faccio casino,
No sono io che ho che ho fatto un po' di confusione:
Visual Basic:
Sub StampaUnioneSingoli_FILE()
'
' StampaUnioneSingoli FILE nel formato desiderato (docx, rtf o PDF) Macro (di default è docx)
'
'
On Error GoTo ErrH
Dim objWdMailMerge As Word.MailMerge
Dim lngRecNum As Long
Dim strPath As String
Dim strFilename As String

Application.ScreenUpdating = False

'NOTA: AL POSTO DI "C:\STAMPE" METTERE LA DIRECTORY DI APPOGGIO CHE VOGLIAMO
strPath = ThisDocument.Path & "\STAMPE\"

Set objWdMailMerge = ThisDocument.MailMerge
With objWdMailMerge
    .Destination = wdSendToNewDocument
    With .DataSource
        .ActiveRecord = wdLastRecord
        lngRecNum = .ActiveRecord
        .ActiveRecord = wdFirstRecord
        Do
            .FirstRecord = .ActiveRecord
            .LastRecord = .ActiveRecord
            strFilename = .DataFields("Nome").Value
            If Len(strFilename) Then

                FName = .DataFields("Nome").Value 'assegna il nome del campo ad una variabile
                Count = 1 'azzera la variabile da associare al nome del file
                FileName = Dir(strPath & FName & " " & Count & ".docx") 'identifica tramite la funzione Dir se il file esiste gia'
                Do While FileName <> "" 'esegue un ciclo fino a non trovare piu' files
                   Count = Count + 1 'aumenta il contatore
                   FileName = Dir(strPath & FName & " " & Count & ".docx") 'riesegue la verifica se ne esistono altri
                Loop
                strFilename = .DataFields("Nome").Value & " " & Count 'assegna alla variabile il nome del campo con il contatore
               
                objWdMailMerge.Execute
                With ActiveDocument
                    ' NOTA: A SECONDA DEL FORMATO CHE DOBBIAMO GENERARE TOGLIERE L'APICE DI IDENTIFICAZIONE COMMENTO DALLA RIGA INTERESSATA
                    .SaveAs strPath & strFilename, wdFormatdoc, AddToRecentFiles:=False
                    ' .SaveAs strFilename, wdFormatRTF, AddToRecentFiles:=False
                    ' .SaveAs strFilename, wdFormatPDF, AddToRecentFiles:=False
                    .Saved = True
                    .Close
                End With
            End If
            If .ActiveRecord = lngRecNum Then Exit Do
            .ActiveRecord = wdNextRecord
        Loop
    End With
End With

ExitProc:
Application.ScreenUpdating = True
Set objWdMailMerge = Nothing
Exit Sub

ErrH:
MsgBox Err.Description
Resume ExitProc

End Sub
Si trovasse il metodo con la data sarebbe bello
cosa intendi?
 

Rubik72

Excel/VBA Expert
Supermoderatore
12 Dicembre 2015
9.468
345
48
Cosenza
Excel 2016
655
Forse intendi questo?
Visual Basic:
Sub StampaUnioneSingoli_FILE()
'
' StampaUnioneSingoli FILE nel formato desiderato (docx, rtf o PDF) Macro (di default è docx)
'
'
On Error GoTo ErrH
Dim objWdMailMerge As Word.MailMerge
Dim lngRecNum As Long
Dim strPath As String
Dim strFilename As String

Application.ScreenUpdating = False

'NOTA: AL POSTO DI "C:\STAMPE" METTERE LA DIRECTORY DI APPOGGIO CHE VOGLIAMO
strPath = ThisDocument.Path & "\STAMPE\"

Set objWdMailMerge = ThisDocument.MailMerge
With objWdMailMerge
    .Destination = wdSendToNewDocument
    With .DataSource
        .ActiveRecord = wdLastRecord
        lngRecNum = .ActiveRecord
        .ActiveRecord = wdFirstRecord
        Do
            .FirstRecord = .ActiveRecord
            .LastRecord = .ActiveRecord
            strFilename = .DataFields("Nome").Value
            If Len(strFilename) Then

                strFilename = .DataFields("Nome").Value & " " & Format(.DataFields("Data").Value, "ddmmmyyyy") 'assegna alla variabile il nome del campo con il contatore
                
                objWdMailMerge.Execute
                With ActiveDocument
                    ' NOTA: A SECONDA DEL FORMATO CHE DOBBIAMO GENERARE TOGLIERE L'APICE DI IDENTIFICAZIONE COMMENTO DALLA RIGA INTERESSATA
                    .SaveAs strPath & strFilename, wdFormatdoc, AddToRecentFiles:=False
                    ' .SaveAs strFilename, wdFormatRTF, AddToRecentFiles:=False
                    ' .SaveAs strFilename, wdFormatPDF, AddToRecentFiles:=False
                    .Saved = True
                    .Close
                End With
            End If
            If .ActiveRecord = lngRecNum Then Exit Do
            .ActiveRecord = wdNextRecord
        Loop
    End With
End With

ExitProc:
Application.ScreenUpdating = True
Set objWdMailMerge = Nothing
Exit Sub

ErrH:
MsgBox Err.Description
Resume ExitProc

End Sub
 

Eymerich

Utente junior
3 Aprile 2020
34
8
Excel 2016
2
No, intendevo più una cosa del genere, ovviamente merito tuo, ho solo fatto un collage di tutte le info che mi hai dato, funziona, ma è un Frankenstein il codice Stranito_pazzo

Visual Basic:
Sub StampaUnioneSingoli_PDF()
'
' StampaUnioneSingoli FILE nel formato desiderato (docx, rtf o PDF) Macro (di default è docx)
'
'
On Error GoTo ErrH
Dim objWdMailMerge  As Word.MailMerge
Dim lngRecNum       As Long
Dim strPath         As String
Dim strFilename     As String
 
    Application.ScreenUpdating = False
 
'NOTA: AL POSTO DI "C:\STAMPE" METTERE LA DIRECTORY DI APPOGGIO CHE VOGLIAMO
    strPath = "C:\Stampe"
 
    Set objWdMailMerge = ThisDocument.MailMerge
    With objWdMailMerge
      .Destination = wdSendToNewDocument
      With .DataSource
        .ActiveRecord = wdLastRecord
        lngRecNum = .ActiveRecord
        .ActiveRecord = wdFirstRecord
        Count = 0
        Do
        Count = Count + 1 'aumenta il contatore
          .FirstRecord = .ActiveRecord
          .LastRecord = .ActiveRecord
'NOTA: AL POSTO DI "Proponente" può essere utilizzato uno qualunque dei campi del file excel con cui si fa il merge, fare attenzione che vi sia corrispoindeza tra tutti i campi utilizzati in Word e i campi del foglio Excel, altrimenti la macro non funziona
          strFilename = .DataFields("Nome").Value & " " & Format(.DataFields("Data").Value, "dd.mm.yyyy")
          If Len(strFilename) Then
' NOTA: A SECONDA DEL TESTO CHE SI VUOLE INSERIRE DOPO IL NOME DEL PROPONENTE, CAMBIARE LA PARTE TRA LE VIRGOLETTE ("_DECRETO")
            strFilename = strPath & strFilename & "_Doc" & " " & Count & ".pdf"
            objWdMailMerge.Execute
            With ActiveDocument
' NOTA: A SECONDA DEL FORMATO CHE DOBBIAMO GENERARE TOGLIERE L'APICE DI IDENTIFICAZIONE COMMENTO DALLA RIGA INTERESSATA
             ' .SaveAs strFilename, wdFormatdoc, AddToRecentFiles:=False
             ' .SaveAs strFilename, wdFormatRTF, AddToRecentFiles:=False
             ' .SaveAs strFilename, wdFormatPDF, AddToRecentFiles:=False
              .Saved = True
              .Close
            End With
          End If
          If .ActiveRecord = lngRecNum Then Exit Do
          .ActiveRecord = wdNextRecord
        Loop
      End With
    End With
 
ExitProc:
    Application.ScreenUpdating = True
    Set objWdMailMerge = Nothing
    Exit Sub
 
ErrH:
    MsgBox Err.Description
    Resume ExitProc
 
End Sub
Ho dovuto inserire nel strfilename ".pdf", poichè .saveas non funzionava più e mi restituiva file senza estensione. (ovviamente toglievo l'apice)
Comunque ho raggiunto il risultato desiderato, quindi GRAZIE, spero possa essere utile ad altri.

Luca
 
  • Like
Reactions: Rubik72

Leo B

Nuovo utente
7 Gennaio 2021
2
1
Excel 2016
0
Buon pomeriggio, sono nuovo del forum e stavo cercando la funzione oggetto di questa discussione, ossia suddividere la stampa unione in tanti file, uno per ogni riga di excel, nominandoli con i campi presi dalla stampaunione/excel. Adattando quello che avete postato, ottengo l'errore: L'oggetto richiesto non è disponibile.
Ammetto che non conosco il linguaggio e probabilmente è un errore banale. Incollo di seguito il testo e vi ringrazio anticipatamente per l'eventuale supporto:

Visual Basic:
Sub StampaUnioneSingoli_FILE()
'
' StampaUnioneSingoli FILE nel formato desiderato (docx, rtf o PDF) Macro (di default è docx)
'
'
On Error GoTo ErrH
Dim objWdMailMerge As Word.MailMerge
Dim lngRecNum As Long
Dim strPath As String
Dim strFilename As String

Application.ScreenUpdating = False

'NOTA: AL POSTO DI "C:\STAMPE" METTERE LA DIRECTORY DI APPOGGIO CHE VOGLIAMO
strPath = ThisDocument.Path

Set objWdMailMerge = ThisDocument.MailMerge
With objWdMailMerge
.Destination = wdSendToNewDocument
With .DataSource
.ActiveRecord = wdLastRecord
lngRecNum = .ActiveRecord
.ActiveRecord = wdFirstRecord
Do
.FirstRecord = .ActiveRecord
.LastRecord = .ActiveRecord
strFilename = .DataFields("Fornitore").Value
If Len(strFilename) Then

FName = .DataFields("Fornitore").Value 'assegna il nome del campo ad una variabile
Count = 1 'azzera la variabile da associare al nome del file
FileName = Dir(strPath & FName & " " & Count & ".docx") 'identifica tramite la funzione Dir se il file esiste gia'
Do While FileName <> "" 'esegue un ciclo fino a non trovare piu' files
Count = Count + 1 'aumenta il contatore
FileName = Dir(strPath & FName & " " & Count & ".docx") 'riesegue la verifica se ne esistono altri
Loop
strFilename = .DataFields("Fornitore").Value

objWdMailMerge.Execute
With ActiveDocument
' NOTA: A SECONDA DEL FORMATO CHE DOBBIAMO GENERARE TOGLIERE L'APICE DI IDENTIFICAZIONE COMMENTO DALLA RIGA INTERESSATA
.SaveAs strPath & strFilename, wdFormatdoc, AddToRecentFiles:=False
' .SaveAs strFilename, wdFormatRTF, AddToRecentFiles:=False
' .SaveAs strFilename, wdFormatPDF, AddToRecentFiles:=False
.Saved = True
.Close
End With
End If
If .ActiveRecord = lngRecNum Then Exit Do
.ActiveRecord = wdNextRecord
Loop
End With
End With

ExitProc:
Application.ScreenUpdating = True
Set objWdMailMerge = Nothing
Exit Sub

ErrH:
MsgBox Err.Description
Resume ExitProc

End Sub
 

Powerwin

VBA Expert
Supermoderatore
17 Marzo 2016
7.320
245
vicino a Milano
2019
231
Ciao,
Ammetto che non conosco il linguaggio e probabilmente è un errore banale.
oltre a non conoscere il linguaggio non hai nemmeno letto (come suggerito all'iscrizione) il Regolamento e gli Avvisi dello Staff dove avresti letto che i codici vanno messi nel TAG CODE (per stavolta provvedo io ma alla prossima stai più attento)

p.s. per il tuo problema hai adeguato i riferimenti ai tuoi file?
 

Sostieni ForumExcel

Aiutaci a sostenere le spese e a mantenere online la community attraverso una libera donazione!