ajhez
08-03-2015, 10:02 AM
Hi all
I have an excel spreadsheet with customer names and data that i'm using to generate a bespoke letter for each customer (approx 500 letters in total). This is all fine and I have included my code below to show how i'm doing this.
I have now had a request that these letters are saved in their respective folders as PDF documents rather than word documents.
Initially I tried to simply change the filepath to save as ".pdf" rather than ".doc", but whilst this generates and saves pdf files in the folders they are corrupt and will not open.
I have seen that there is a method of exportingasfixedformat into PDF which appears to work, but it then stops my previous code from continuing to generate and save a letter for each customer as required.
Any ideas?
My old code that worked but saved as word docs not PDFs
Option Explicit
Const MainFilePath As String = "C:\Users\herriale\Desktop\FINAL TT\Dutch\"
Const FilePath As String = "C:\Users\herriale\Desktop\FINAL TT\Dutch\Letters\"
Dim wd As New Word.Application
Dim CustomerCell As Range
Sub GenerateLetters()
Dim doc As Word.Document
wd.Visible = True
Dim CustomerRange As Range
Range("B6").Select
Set CustomerRange = Range( _
ActiveCell, _
ActiveCell.End(xlDown))
For Each CustomerCell In CustomerRange
Set doc = wd.Documents.Open(MainFilePath & "Trade Invesment Letter 2016 Netherlands 07 07 15 FINAL DUTCH.docm")
'introletter
CopyCell "bmaccountname1", 1
CopyCell "bmcontactperson", 9
CopyCell "bmstreetname", 10
CopyCell "bmstreetnumber", 11
CopyCell "bmzipcode", 12
CopyCell "bmcity", 13
CopyCell "bmcontactperson2", 9
CopyCell "bmmanagername1", 6
CopyCell "bmmanagertitle1", 7
'ttpackageletter
CopyCell "bmaccountname2", 1
CopyCell "bmaccountname3", 1
'ttstatementoninvoice
CopyCell "bmoninvoiceheader", 35
CopyCell "bmlogistics", 25
CopyCell "bmordervolume", 26
CopyCell "bmteamwear", 27
CopyCell "bmmerkconcepten", 30
CopyCell "bmwinkelevaluatie", 32
CopyCell "bmrsm", 31
CopyCell "bmedi", 33
CopyCell "bmreturns", 34
CopyCell "bmoninvoicetotal", 35
'ttstatementoffinvoice
CopyCell "bmoffinvoiceheader", 48
CopyCell "bmsettlement", 37
CopyCell "bmguarantee", 38
CopyCell "bmnetto", 41
CopyCell "bmmarkt", 42
CopyCell "bmactivering", 45
CopyCell "bmoffinvoicetotal", 48
'ttappendixletter
CopyCell "bmlogistics1", 22
CopyCell "bmlogistics2", 24
CopyCell "bmlogistics3", 23
CopyCell "bmlogistics4", 25
doc.DeleteSections
doc.CleanUp1
doc.CleanTables
doc.UpdateFields
doc.SaveAs2 FilePath & CustomerCell.Offset(0, 15).Value & "\" & CustomerCell.Offset(0, 1).Value & ".doc"
doc.Close
Next CustomerCell
wd.Quit
MsgBox "Completed!"
End Sub
Sub CopyCell(bmaccountname As String, ColumnOffset As Integer)
wd.Selection.GoTo What:=wdGoToBookmark, Name:=bmaccountname
wd.Selection.TypeText CustomerCell.Offset(0, ColumnOffset).Value
End Sub
Here is my amended code that doesnt seem to work for me:
Option Explicit
Const MainFilePath As String = "C:\Users\herriale\Desktop\FINAL TT\Dutch\"
Const FilePath As String = "C:\Users\herriale\Desktop\FINAL TT\Dutch\Letters\"
Dim wd As New Word.Application
Dim CustomerCell As Range
Sub GenerateLetters()
Dim doc As Word.Document
wd.Visible = True
Dim CustomerRange As Range
Range("B6").Select
Set CustomerRange = Range( _
ActiveCell, _
ActiveCell.End(xlDown))
For Each CustomerCell In CustomerRange
Set doc = wd.Documents.Open(MainFilePath & "Trade Invesment Letter 2016 Netherlands 07 07 15 FINAL DUTCH.docm")
'introletter
CopyCell "bmaccountname1", 1
CopyCell "bmcontactperson", 9
CopyCell "bmstreetname", 10
CopyCell "bmstreetnumber", 11
CopyCell "bmzipcode", 12
CopyCell "bmcity", 13
CopyCell "bmcontactperson2", 9
CopyCell "bmmanagername1", 6
CopyCell "bmmanagertitle1", 7
'ttpackageletter
CopyCell "bmaccountname2", 1
CopyCell "bmaccountname3", 1
'ttstatementoninvoice
CopyCell "bmoninvoiceheader", 35
CopyCell "bmlogistics", 25
CopyCell "bmordervolume", 26
CopyCell "bmteamwear", 27
CopyCell "bmmerkconcepten", 30
CopyCell "bmwinkelevaluatie", 32
CopyCell "bmrsm", 31
CopyCell "bmedi", 33
CopyCell "bmreturns", 34
CopyCell "bmoninvoicetotal", 35
'ttstatementoffinvoice
CopyCell "bmoffinvoiceheader", 48
CopyCell "bmsettlement", 37
CopyCell "bmguarantee", 38
CopyCell "bmnetto", 41
CopyCell "bmmarkt", 42
CopyCell "bmactivering", 45
CopyCell "bmoffinvoicetotal", 48
'ttappendixletter
CopyCell "bmlogistics1", 22
CopyCell "bmlogistics2", 24
CopyCell "bmlogistics3", 23
CopyCell "bmlogistics4", 25
doc.DeleteSections
doc.CleanUp1
doc.CleanTables
doc.UpdateFields
With ActiveDocument
.ExportAsFixedFormat OutputFileName:=FilePath & CustomerCell.Offset(0, 15).Value & "\" & CustomerCell.Offset(0, 1).Value & ".pdf", _
ExportFormat:=wdExportFormatPDF, OpenAfterExport:=False, _
OptimizeFor:=wdExportOptimizeForPrint, Range:=wdExportAllDocument, _
Item:=wdExportDocumentContent, IncludeDocProps:=True, KeepIRM:=True, _
CreateBookmarks:=wdExportCreateNoBookmarks, DocStructureTags:=True, _
BitmapMissingFonts:=True, UseISO19005_1:=False
End With
Next CustomerCell
wd.Quit
MsgBox "Completed!"
End Sub
Sub CopyCell(bmaccountname As String, ColumnOffset As Integer)
wd.Selection.GoTo What:=wdGoToBookmark, Name:=bmaccountname
wd.Selection.TypeText CustomerCell.Offset(0, ColumnOffset).Value
End Sub
I have an excel spreadsheet with customer names and data that i'm using to generate a bespoke letter for each customer (approx 500 letters in total). This is all fine and I have included my code below to show how i'm doing this.
I have now had a request that these letters are saved in their respective folders as PDF documents rather than word documents.
Initially I tried to simply change the filepath to save as ".pdf" rather than ".doc", but whilst this generates and saves pdf files in the folders they are corrupt and will not open.
I have seen that there is a method of exportingasfixedformat into PDF which appears to work, but it then stops my previous code from continuing to generate and save a letter for each customer as required.
Any ideas?
My old code that worked but saved as word docs not PDFs
Option Explicit
Const MainFilePath As String = "C:\Users\herriale\Desktop\FINAL TT\Dutch\"
Const FilePath As String = "C:\Users\herriale\Desktop\FINAL TT\Dutch\Letters\"
Dim wd As New Word.Application
Dim CustomerCell As Range
Sub GenerateLetters()
Dim doc As Word.Document
wd.Visible = True
Dim CustomerRange As Range
Range("B6").Select
Set CustomerRange = Range( _
ActiveCell, _
ActiveCell.End(xlDown))
For Each CustomerCell In CustomerRange
Set doc = wd.Documents.Open(MainFilePath & "Trade Invesment Letter 2016 Netherlands 07 07 15 FINAL DUTCH.docm")
'introletter
CopyCell "bmaccountname1", 1
CopyCell "bmcontactperson", 9
CopyCell "bmstreetname", 10
CopyCell "bmstreetnumber", 11
CopyCell "bmzipcode", 12
CopyCell "bmcity", 13
CopyCell "bmcontactperson2", 9
CopyCell "bmmanagername1", 6
CopyCell "bmmanagertitle1", 7
'ttpackageletter
CopyCell "bmaccountname2", 1
CopyCell "bmaccountname3", 1
'ttstatementoninvoice
CopyCell "bmoninvoiceheader", 35
CopyCell "bmlogistics", 25
CopyCell "bmordervolume", 26
CopyCell "bmteamwear", 27
CopyCell "bmmerkconcepten", 30
CopyCell "bmwinkelevaluatie", 32
CopyCell "bmrsm", 31
CopyCell "bmedi", 33
CopyCell "bmreturns", 34
CopyCell "bmoninvoicetotal", 35
'ttstatementoffinvoice
CopyCell "bmoffinvoiceheader", 48
CopyCell "bmsettlement", 37
CopyCell "bmguarantee", 38
CopyCell "bmnetto", 41
CopyCell "bmmarkt", 42
CopyCell "bmactivering", 45
CopyCell "bmoffinvoicetotal", 48
'ttappendixletter
CopyCell "bmlogistics1", 22
CopyCell "bmlogistics2", 24
CopyCell "bmlogistics3", 23
CopyCell "bmlogistics4", 25
doc.DeleteSections
doc.CleanUp1
doc.CleanTables
doc.UpdateFields
doc.SaveAs2 FilePath & CustomerCell.Offset(0, 15).Value & "\" & CustomerCell.Offset(0, 1).Value & ".doc"
doc.Close
Next CustomerCell
wd.Quit
MsgBox "Completed!"
End Sub
Sub CopyCell(bmaccountname As String, ColumnOffset As Integer)
wd.Selection.GoTo What:=wdGoToBookmark, Name:=bmaccountname
wd.Selection.TypeText CustomerCell.Offset(0, ColumnOffset).Value
End Sub
Here is my amended code that doesnt seem to work for me:
Option Explicit
Const MainFilePath As String = "C:\Users\herriale\Desktop\FINAL TT\Dutch\"
Const FilePath As String = "C:\Users\herriale\Desktop\FINAL TT\Dutch\Letters\"
Dim wd As New Word.Application
Dim CustomerCell As Range
Sub GenerateLetters()
Dim doc As Word.Document
wd.Visible = True
Dim CustomerRange As Range
Range("B6").Select
Set CustomerRange = Range( _
ActiveCell, _
ActiveCell.End(xlDown))
For Each CustomerCell In CustomerRange
Set doc = wd.Documents.Open(MainFilePath & "Trade Invesment Letter 2016 Netherlands 07 07 15 FINAL DUTCH.docm")
'introletter
CopyCell "bmaccountname1", 1
CopyCell "bmcontactperson", 9
CopyCell "bmstreetname", 10
CopyCell "bmstreetnumber", 11
CopyCell "bmzipcode", 12
CopyCell "bmcity", 13
CopyCell "bmcontactperson2", 9
CopyCell "bmmanagername1", 6
CopyCell "bmmanagertitle1", 7
'ttpackageletter
CopyCell "bmaccountname2", 1
CopyCell "bmaccountname3", 1
'ttstatementoninvoice
CopyCell "bmoninvoiceheader", 35
CopyCell "bmlogistics", 25
CopyCell "bmordervolume", 26
CopyCell "bmteamwear", 27
CopyCell "bmmerkconcepten", 30
CopyCell "bmwinkelevaluatie", 32
CopyCell "bmrsm", 31
CopyCell "bmedi", 33
CopyCell "bmreturns", 34
CopyCell "bmoninvoicetotal", 35
'ttstatementoffinvoice
CopyCell "bmoffinvoiceheader", 48
CopyCell "bmsettlement", 37
CopyCell "bmguarantee", 38
CopyCell "bmnetto", 41
CopyCell "bmmarkt", 42
CopyCell "bmactivering", 45
CopyCell "bmoffinvoicetotal", 48
'ttappendixletter
CopyCell "bmlogistics1", 22
CopyCell "bmlogistics2", 24
CopyCell "bmlogistics3", 23
CopyCell "bmlogistics4", 25
doc.DeleteSections
doc.CleanUp1
doc.CleanTables
doc.UpdateFields
With ActiveDocument
.ExportAsFixedFormat OutputFileName:=FilePath & CustomerCell.Offset(0, 15).Value & "\" & CustomerCell.Offset(0, 1).Value & ".pdf", _
ExportFormat:=wdExportFormatPDF, OpenAfterExport:=False, _
OptimizeFor:=wdExportOptimizeForPrint, Range:=wdExportAllDocument, _
Item:=wdExportDocumentContent, IncludeDocProps:=True, KeepIRM:=True, _
CreateBookmarks:=wdExportCreateNoBookmarks, DocStructureTags:=True, _
BitmapMissingFonts:=True, UseISO19005_1:=False
End With
Next CustomerCell
wd.Quit
MsgBox "Completed!"
End Sub
Sub CopyCell(bmaccountname As String, ColumnOffset As Integer)
wd.Selection.GoTo What:=wdGoToBookmark, Name:=bmaccountname
wd.Selection.TypeText CustomerCell.Offset(0, ColumnOffset).Value
End Sub