Excel
VBA
VBA
Public Const const_plcHold_1_Row As Integer = 7
Public Const const_plcHold_2_Row As Integer = 8
Public Const const_tblFirstRow As Integer = 11
Public Const const_tblFirstCol As Integer = 2
Public Const const_tblCols As Integer = 3
Public Const const_pgBrkOptRow As Integer = 16
Public Const const_paragRow As Integer = 19
Sub crea_file()
Dim myTemplate As String
Dim myApp As Word.Application
Dim myDoc As Word.Document
Dim myFileName As String
Dim myParagraph As Word.Paragraph
Dim myTable As Word.Table
Dim myRange As Word.Range
Dim myTableRows As Integer
Dim myExlRow As Integer
Dim myExlCol As Integer
Dim myWrdRow As Integer
Dim myWrdCol As Integer
'template name
myTemplate = ThisWorkbook.Path & "\" & Cells(2, 2)
Set myApp = CreateObject("Word.Application")
Set myDoc = myApp.Documents.Open(myTemplate)
'file output name
myFileName = ThisWorkbook.Path & "\" & Cells(3, 2) & Cells(3, 4)
myApp.Visible = True
'find and replace placeholders
With myDoc
.Application.Selection.Find.Text = "<>"
.Application.Selection.Find.Replacement.Text = Cells(const_plcHold_1_Row, 2)
.Application.Selection.Find.Execute Replace:=wdReplaceAll
.Application.Selection.EndOf
.Application.Selection.Find.Text = "<>"
.Application.Selection.Find.Replacement.Text = Cells(const_plcHold_2_Row, 2)
.Application.Selection.Find.Execute Replace:=wdReplaceAll
.Application.Selection.EndOf
End With
'insert a page break at the bookmark "myBookmark", after the new paragraph
If Cells(const_pgBrkOptRow, 4) = "x" Then
Set myRange = myDoc.Bookmarks("myBookmark").Range
myRange.Collapse wdCollapseStart
myRange.InsertBreak wdPageBreak
End If
'add a new paragraph at the bookmark "myBookmark", after the table
Set myParagraph = myDoc.Content.Paragraphs.Add(myDoc.Bookmarks("myBookmark").Range)
myParagraph.Range.Text = Cells(const_paragRow, 2)
'add a table at the bookmark "myBookmark"
myExlRow = const_tblFirstRow
myExlCol = const_tblFirstCol
If Cells(myExlRow, myExlCol) <> "" Then
While Cells(myExlRow, myExlCol) <> ""
myExlRow = myExlRow + 1
Wend
myTableRows = myExlRow - const_tblFirstRow
Set myTable = myDoc.Tables.Add(myDoc.Bookmarks("myBookmark").Range, myTableRows, const_tblCols) 'table with variable rows and "const_tblCols" columns
myTable.Range.ParagraphFormat.SpaceAfter = 0
myTable.Range.ParagraphFormat.SpaceBefore = 0
myTable.Borders.Enable = True
myWrdRow = 1
myWrdCol = 1
myExlRow = const_tblFirstRow
myExlCol = const_tblFirstCol
For myWrdRow = 1 To myTableRows
While myWrdCol <= const_tblCols
myTable.Cell(myWrdRow, myWrdCol).Range.Text = Cells(myExlRow, myExlCol)
myExlCol = myExlCol + 1
myWrdCol = myWrdCol + 1
Wend
myExlCol = const_tblFirstCol
myWrdCol = 1
myExlRow = myExlRow + 1
Next
myTable.Columns(1).Width = myApp.CentimetersToPoints(4)
myTable.Columns(2).Width = myApp.CentimetersToPoints(4)
myTable.Columns(3).Width = myApp.CentimetersToPoints(4)
End If
Select Case Cells(4, 4)
Case 1
'save as Word file
myDoc.SaveAs2 Filename:=myFileName & ".docx", FileFormat:=wdFormatXMLDocument, AddtoRecentFiles:=False
Case 2
'save as PDF
myDoc.SaveAs2 Filename:=myFileName & ".pdf", FileFormat:=wdFormatPDF, AddtoRecentFiles:=False
End Select
myDoc.Close False
myApp.Quit False
CloseWordDocuments
MsgBox "The file:" & Chr(13) & myFileName & Chr(13) & "has been created."
'open destination folder
Shell "cmd /C start """" /max """ & ThisWorkbook.Path & """", vbHide
End Sub
Sub CloseWordDocuments()
'https://stackoverflow.com/questions/41100661/closing-word-application-from-excel-vba
On Error Resume Next
Dim objWordApp As Object
Dim objDoc As Object
'Attempt to get an existing Word application object
Set objWordApp = GetObject(, "Word.Application")
'Check if Word application object is successfully set
If Not objWordApp Is Nothing Then
'Loop through all open Word documents and close them without saving
For Each objDoc In objWordApp.Documents
objDoc.Close False ' Close without saving changes
Next objDoc
'Quit Word application
objWordApp.Quit
Set objWordApp = Nothing
End If
End Sub