Hello,
In Word there is no code so far.
The code in Excel that brings the data from the one table where it is collected to Word and into PDF is the following.
It is put together from various sources so it is not perfect and also not finished yet. I have to configure the PDF part yet so the PDF is made on fly together with the word document.
Sub CreateWordDocuments()
Dim CustRow, CustCol, LastRow, TemplRow, DaysSince, FrDays, ToDays As Long
Dim DocLoc, TagName, TagValue, TemplName, FileName As String
Dim CurDt, LastAppDt As Date
Dim WordDoc, WordApp, OutApp, OutMail As Object
Dim VarFormat As String
Dim VarValue As String
Dim WordContent As Word.Range
Dim date_example As String
date_example = Now()
With Sheet1
If .Range("B3").Value = Empty Then
MsgBox "Prosim izberi pravo podlogo iz seznama podlog"
.Range("H3").Select
Exit Sub
End If
TemplRow = .Range("B3").Value 'Set Template Row
TemplName = .Range("H3").Value 'Set Template Name
FrDays = .Range("M3").Value 'Set From Days
ToDays = .Range("O3").Value 'Set To Days
DocLoc = Sheet2.Range("F" & TemplRow).Value 'Word Document Filename
'Open Word Template
On Error Resume Next 'If Word is already running
Set WordApp = GetObject("Word.Application")
If Err.Number <> 0 Then
'Launch a new instance of Word
Err.Clear
'On Error GoTo Error_Handler
Set WordApp = CreateObject("Word.Application")
WordApp.Visible = True 'Make the application visible to the user
End If
LastRow = .Range("E9999").End(xlUp).Row 'Determine Last Row in Table
For CustRow = 8 To LastRow
DaysSince = .Range("N" & CustRow).Value
If .Range("O" & CustRow).Value = "" And DaysSince >= FrDays And DaysSince <= ToDays Then
Set WordDoc = WordApp.Documents.Open(FileName:=DocLoc, ReadOnly:=False) 'Open Template
For CustCol = 4 To 200 'Move Through Columns
If .Cells(4, CustCol).Value = "Splosno" Then VarFormat = "General" Else: VarFormat = .Cells(5, CustCol).Value 'Determine Variable Format
TagName = .Cells(7, CustCol).Value 'Tag Name
TagValue = .Cells(CustRow, CustCol).Value 'Tag Value
With WordDoc.Content.Find
.Text = TagName
.Replacement.Text = Application.WorksheetFunction.Text(TagValue, VarFormat)
.Wrap = wdFindContinue
.Execute Replace:=wdReplaceAll 'Find & Replace all instances
End With
Next CustCol
If .Range("J3").Value = "PDF" Then
FileName = ThisWorkbook.Path & "\" & .Range("E" & CustRow).Value & "_" & .Range("F" & CustRow).Value & ".pdf" 'Create full filename & Path with current workbook location, Last Name & First Name
WordDoc.ExportAsFixedFormat OutputFileName:=FileName, ExportFormat:=wdExportFormatPDF
WordDoc.Close False
Else: 'If Word
FileName = ThisWorkbook.Path & "\" & .Range("H" & CustRow).Value & " " & .Range("D" & CustRow).Value & "-" & .Range("U" & CustRow).Value & "-" & .Range("R" & CustRow).Value & ".docx"
WordDoc.SaveAs FileName
End If
.Range("O" & CustRow).Value = "DA" 'pre je bilo to' TemplName 'Template Name
.Range("P" & CustRow).Value = Format(date_example, "dd.mm.yyyy hh:nn")
.Range("R" & CustRow) = Format(date_example, "yyyy")
If .Range("Q3").Value = "Email" Then
Set OutApp = CreateObject("Outlook.Application") 'Create Outlook Application
Set OutMail = OutApp.CreateItem(0) 'Create Email
With OutMail
.To = Sheet1.Range("L" & CustRow).Value
.Subject = "Hi, " & Sheet1.Range("F" & CustRow).Value & " We Miss You"
.Body = "Hello, " & Sheet1.Range("F" & CustRow).Value & " Its been a while since we have seen you so we wanted to send you a special letter. Please see the attached file"
.Attachments.Add FileName
.Display 'To send without Displaying change .Display to .Send
End With
Else: 'Print Out
WordDoc.PrintOut
WordDoc.Close
End If
Kill (FileName) 'Deletes the PDF or Word that was just created
End If '3 condition met
Next CustRow
WordApp.Quit
End With
End Sub
BR
Reply With Quote
Originally Posted by PeterKom
