Thanks, I have checked and it works for one picture.
But I can have 4 tables this means 4 different products so also 4 different picture.
Please check attached updated Word Template.
Now my code checks row 7 from column 4 to 200 (but this might easily get bigge rduring time) where the tags are written.
Then it replaces the same tags in the Word template accordingly to the value under those tage in Excel for all rows that meet condition
If .Range("O" & CustRow).Value = "" And TemplName <> "ROČNA PONUDBA" Then
So would it be possible to do the same for the pictures to have Picture tags, <<Piciture>>, <<Piciture2>>, <<Piciture3>>, <<Piciture4>>, .... and so on in that same row from column 4-200, because i also want to add other configurators
for other products that also will add a Picture. It may also be the possible to have mixed offers with a template for product like attached and some additionl product si I dont want to mix those tags. Lets say tag <<Piciture>> - <<Piciture4>> should only be for this particular product RWM and so on.
The whole code now look like this. For he testing purpose I now just added a path inside the code to see how it works.
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()
Dim SaveNr As String
Dim str As String
Dim fol As String
Dim oTable As Word.Table
Dim oRng As Word.Range
Dim oShape As Word.InlineShape
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 'ROČNA PONDUBA
If .Range("O" & CustRow).Value = "" And TemplName <> "ROČNA PONUDBA" 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
Set WordDoc = ActiveDocument
Set oTable = WordDoc.Tables(1)
oTable.AutoFitBehavior (wdAutoFitFixed)
Set oRng = oTable.Range
With oRng.Find
Do While .Execute(findText:="<<Picture>>")
oRng.Text = ""
oRng.InlineShapes.AddPicture "C:\Users\Peter\Desktop\kalk\PODLOGE PONUDB\SLIKE\RWM\W-CE.jpg" 'the path from the worksheet
Exit Do
Loop
End With
Dim Tbl As Long, Rw As Long, StrData As String
With WordDoc
For Tbl = 4 To 2 Step -1
With .Tables(Tbl)
StrData = ""
For Rw = 3 To 12
StrData = StrData & Split(.Cell(Rw, 2).Range.Text, vbCr)(0) '.Bookmarks("Schedule_of_Payments").Range.Tables(1).Delete
Next
If StrData = "" Then .Range.Bookmarks(1).Range.Delete 'If StrData = "" Then .Range.Bookmarks(1).Range.Tables(1).Delete
End With
Next
End With
If TemplName <> "ROČNA PONUDBA" Then
SaveNr = .Range("D" & CustRow).Text
str = "C:\Users\Peter\Desktop\kalk\2020\" & .Range("H" & CustRow).Value & " " & SaveNr & "-" & .Range("U" & CustRow).Value & "-" & .Range("R" & CustRow).Value & "\"
fol = Dir(str, vbDirectory)
If fol = "" Then MkDir str
FileName = str & .Range("H" & CustRow).Value & " " & SaveNr & "-" & .Range("U" & CustRow).Value & "-" & .Range("R" & CustRow).Value & ".docx"
WordDoc.SaveAs FileName 'Saves Word document
FileName = str & .Range("H" & CustRow).Value & " " & SaveNr & "-" & .Range("U" & CustRow).Value & "-" & .Range("R" & CustRow).Value & ".pdf" 'Create full filename & Path with current workbook location, Last Name & First Name
On Error Resume Next
Kill (FileName) 'Delete filename with the same name if it exists
On Error GoTo 0
On Error Resume Next
WordDoc.ExportAsFixedFormat OutputFileName:=FileName, ExportFormat:=wdExportFormatPDF 'Exports Word document as PDF in and saves in same folder as Word document
'WordDoc.Close False
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")' 'SEM ODRSTRANIL KER NI POTREBNO, IMAM FORMULO ZA TO, KER JE PODATEK POTREBEN PREJ'
'WordDoc.Close
End If '3 condition met
Next CustRow
'WordApp.Quit 'WordApp.Quit Does not quit Word when testing templates
End With
End Sub
Peter