VBA - Non riesco a creare cicli e salvare in PDF

di
tarkus82
il
2 risposte
T
tarkus82
Pochi posts
Iscritto da
feb, 2019
Messaggi:
2

VBA - Non riesco a creare cicli e salvare in PDF

Ciao a tutti. Sono Daniele, sono nuovo di questo forum e anche dei linguaggi di programmazione. Sto studiando il basic e sto avendo problemi con una macro che ho creato per velocizzare le operazioni in ufficio. In poche parole io ho un elenco di nomi e cognomi con dati personali di alcune persone che devono ricevere degli attestati di partecipazione. Ho creato un file word con l'attestato già pronto e ho aggiunto i 4 segnalibri (Nome, cognome, data di nascita e comune di nascita) che devo trasportare dal file excel. Sono riuscito a creare il VBA prendendo idee e modificando codici trovati in rete, ma ora non riesco a fare due cose: fare gli attestati per ogni riga (il mio codice riesce a generare un attestato alla volta) ed esportare gli attestati in formato pdf e non word. Vi allego il codice, vi avrei inviato anche i due file in questione, ma non so perchè non riesco ad allegarli. Spero che mi sappiate aiutare. Grazie mille in anticipo.

Option Explicit
Public URec As Long
Public x As Byte
Const Path As String = "C:\Prove\Word\"
Const FileWord As String = "Baseok.docx"

Sub Copia_su_Word()
On Error GoTo 10
Application.ScreenUpdating = False
Dim FileDoc As String
Dim wrdApp, wrdDoc
Dim I As Long
Const sFILENAME As String = Path & FileWord
If ActiveCell.Row < 6 Or ActiveCell.Row > Range("A" & Rows.Count).End(xlUp).Row Then End
FileDoc = Path & Cells(ActiveCell.Row, 5)
Set wrdApp = CreateObject("Word.Application")
wrdApp.Visible = True
Set wrdDoc = wrdApp.Documents.Open(sFILENAME)
With wrdDoc
.Bookmarks("Cognome").Range.Text = Cells(ActiveCell.Row, 3) ' Cognome
.Bookmarks("Nome").Range.Text = Cells(ActiveCell.Row, 4) ' Nome"
.Bookmarks("Data").Range.Text = Cells(ActiveCell.Row, 7) ' Data"
.Bookmarks("Luogo").Range.Text = Cells(ActiveCell.Row, 6) ' Luogo"

End With
wrdApp.ActiveDocument.SaveAs Filename:=FileDoc
wrdApp.Quit
Application.ScreenUpdating = True
Cells(ActiveCell.Row + 1, 3).Select
Application.ScreenUpdating = True
For I = 0 To 100
If Cells(I, 3) = "" Then
Exit Sub
End If
Cells(I, 2) = Cells(I, 1)
Next I
10:
End Sub

2 Risposte

  • O
    oregon
    Super Famoso
    Iscritto da
    nov, 2011
    Messaggi:
    21785

    Re: VBA - Non riesco a creare cicli e salvare in PDF

    Usa i tag CODE per il codice, vedi regolamento.

    Devi impostare un ciclo For subito dopo la Open che si concluda subito dopo la Save.
  • T
    tarkus82
    Pochi posts
    Iscritto da
    feb, 2019
    Messaggi:
    2

    Re: VBA - Non riesco a creare cicli e salvare in PDF

    oregon ha scritto:

    Usa i tag CODE per il codice, vedi regolamento.

    Devi impostare un ciclo For subito dopo la Open che si concluda subito dopo la Save.
    Scusa, ecco fatto. So cosa si deve fare nella teoria, sto studiando da 2 settimane il VBA, ma nella pratica non riesco a farlo, sto imparando tutto da solo ed è una sfida abbastanza difficile per me. Per convertire gli attestati in PDF ho letto che dovrei usare il metodo ExportAsFixedFormat dell'oggetto Document, ma ho fatto diverse prove e quando eseguo il sub mi da sempre errore. Riusciresti ad aiutarmi a correggere il codice?
    Option Explicit
Public URec As Long
Public x As Byte
Const Path As String = "C:\Prove\Word\"
Const FileWord As String = "Baseok.docx"

Sub Copia_su_Word()
On Error GoTo 10
Application.ScreenUpdating = False
Dim FileDoc As String
Dim wrdApp, wrdDoc
Dim I As Long
Const sFILENAME As String = Path & FileWord
If ActiveCell.Row < 6 Or ActiveCell.Row > Range("A" & Rows.Count).End(xlUp).Row Then End
FileDoc = Path & Cells(ActiveCell.Row, 5)
Set wrdApp = CreateObject("Word.Application")
wrdApp.Visible = True
Set wrdDoc = wrdApp.Documents.Open(sFILENAME)
With wrdDoc
.Bookmarks("Cognome").Range.Text = Cells(ActiveCell.Row, 3) ' Cognome
.Bookmarks("Nome").Range.Text = Cells(ActiveCell.Row, 4) ' Nome"
.Bookmarks("Data").Range.Text = Cells(ActiveCell.Row, 7) ' Data"
.Bookmarks("Luogo").Range.Text = Cells(ActiveCell.Row, 6) ' Luogo"

End With
wrdApp.ActiveDocument.SaveAs Filename:=FileDoc
wrdApp.Quit
Application.ScreenUpdating = True
Cells(ActiveCell.Row + 1, 3).Select
Application.ScreenUpdating = True
For I = 0 To 100
If Cells(I, 3) = "" Then
Exit Sub
End If
Cells(I, 2) = Cells(I, 1)
Next I
10:
End Sub
Devi accedere o registrarti per scrivere nel forum
2 risposte