How to make a Loop in an If-Statement - excel

Question

Short explanation: There are 3.Letter Templates and i want them to print per Button. But the main problem here is, that the Code is Printing the Template for every Person in the Worksheet also if the Person already had a Letter. It should look something like this.
-If the selected letter in "G3" is 1. Letter then send them only to People where the Cell Range in "Z" is Empty
-If the selected letter in "G3" is 2. Letter then send them only to People where the Cell in Range "Z" is 1.Letter
-If the selected letter in "G3" is 3. Letter then send them only to People where the Cell in Range "Z" is 2.Letter
What do i need to write right here?
Thank you for your answer in Advance!
https://i.stack.imgur.com/1NRbv.png
Option Explicit
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 OutApp, OutMail As Object
Dim WordContent As Word.Range
Dim WordDoc As Word.Document
Dim WordApp As Word.Application
With Tabelle1
If IsEmpty(Range("G3").Value) = True Then
MsgBox "Bitte wählen sie eine Vorlage aus"
.Range("G3").Select
Exit Sub
End If
TemplRow = .Range("B3").Value
TemplName = .Range("G3").Value
FrDays = .Range("L3").Value
ToDays = .Range("N3").Value
DocLoc = Tabelle2.Range("F" & TemplRow).Value
On Error Resume Next
Set WordApp = GetObject("Word.Application")
If Err.Number <> 0 Then
Err.Clear
Set WordApp = CreateObject("Word.Application")
WordApp.Visible = True
End If
***LastRow = .Range("E9999").End(xlUp).Row
For CustRow = 8 To LastRow
DaysSince = .Range("P" & CustRow).Value
If TemplName <> .Range("Z" & CustRow).Value And DaysSince >= FrDays And DaysSince <= ToDays Then
Set WordDoc = WordApp.Documents.Open(FileName:=DocLoc, ReadOnly:=False)
For CustCol = 5 To 26
TagName = .Cells(7, CustCol).Value
TagValue = .Cells(CustRow, CustCol).Value
With WordDoc.Content.Find
.Text = TagName
.Replacement.Text = TagValue
.Wrap = wdFindContinue
.Execute Replace:=wdReplaceAll
End With***
Next CustCol
If .Range("I3").Value = "PDF" Then
FileName = "Filename" & "\" & .Range("H" & CustRow).Value & " " & .Range("G" & CustRow).Value & " " & .Range("G3").Value & ".pdf"
WordDoc.ExportAsFixedFormat OutputFileName:=FileName, ExportFormat:=wdExportFormatPDF
WordDoc.Close False
Else:
FileName = ThisWorkbook.Path & "\" & .Range("H" & CustRow).Value & "_" & .Range("G" & CustRow).Value & ".docx"
WordDoc.SaveAs FileName
End If
.Range("Z" & CustRow).Value = TemplName
.Range("AA" & CustRow).Value = Now
If .Range("P3").Value = "Email" Then
Set OutApp = CreateObject("Outlook.Application")
Set OutMail = OutApp.CreateItem(0)
With OutMail
.To = Tabelle1.Range("K" & CustRow).Value
.Subject = "Hallo, " & Tabelle1.Range("F" & CustRow).Value & "Test Test Test"
.Body = "Hallo, " & Tabelle1.Range("F" & CustRow).Value & "Test Test Test Test"
.Attachments.Add FileName
.Display
End With
Else:
WordDoc.PrintOut
WordDoc.Close
End If
Kill False '(FileName)
End If
Next CustRow
WordApp.Quit
End With
End Sub

Answer 1

Try the following: (not tested)
Sub CreateWordDocuments()
Dim CustRow As Long, CustCol As Long, LastRow As Long, TemplRow As Long, DaysSince As Long, FrDays As Long, ToDays As Long
Dim DocLoc As String, TagName As String, TagValue As String, TemplName As String, FileName As String
Dim CurDt As Date, LastAppDt As Date
Dim OutApp As Object, OutMail As Object
Dim WordContent As Word.Range
Dim WordDoc As Word.Document
Dim WordApp As Word.Application
'*~
Dim sLastSentTemplate As String
With Tabelle1
If IsEmpty(Range("G3").Value) = True Then
MsgBox "Bitte wählen sie eine Vorlage aus"
.Range("G3").Select
Exit Sub
End If
TemplRow = .Range("B3").Value
TemplName = .Range("G3").Value
FrDays = .Range("L3").Value
ToDays = .Range("N3").Value
DocLoc = Tabelle2.Range("F" & TemplRow).Value
'*~ workout the last sent template name
'* this is what you'll be searching for in column Z
sLastTemplateTarget = GetLastSentTemplate(TemplName)
On Error Resume Next
Set WordApp = GetObject("Word.Application")
If Err.Number <> 0 Then
Err.Clear
Set WordApp = CreateObject("Word.Application")
WordApp.Visible = True
End If
'***LastRow = .Range("E9999").End(xlUp).Row
'*~
LastRow = .Cells(.Rows.Count, "E").End(xlUp).Row
For CustRow = 8 To LastRow
DaysSince = .Range("P" & CustRow).Value
'*~ changed TemplName to sLastSentTemplate
If sLastSentTemplate = .Range("Z" & CustRow).Value And DaysSince >= FrDays And DaysSince <= ToDays Then
Set WordDoc = WordApp.Documents.Open(FileName:=DocLoc, ReadOnly:=False)
For CustCol = 5 To 26
TagName = .Cells(7, CustCol).Value
TagValue = .Cells(CustRow, CustCol).Value
With WordDoc.Content.Find
.Text = TagName
.Replacement.Text = TagValue
.Wrap = wdFindContinue
.Execute Replace:=wdReplaceAll
End With '***
Next CustCol
If .Range("I3").Value = "PDF" Then
FileName = "Filename" & "\" & .Range("H" & CustRow).Value & " " & .Range("G" & CustRow).Value & " " & .Range("G3").Value & ".pdf"
WordDoc.ExportAsFixedFormat OutputFileName:=FileName, ExportFormat:=wdExportFormatPDF
WordDoc.Close False
Else:
FileName = ThisWorkbook.Path & "\" & .Range("H" & CustRow).Value & "_" & .Range("G" & CustRow).Value & ".docx"
WordDoc.SaveAs FileName
End If
.Range("Z" & CustRow).Value = TemplName
.Range("AA" & CustRow).Value = Now
If .Range("P3").Value = "Email" Then
Set OutApp = CreateObject("Outlook.Application")
Set OutMail = OutApp.CreateItem(0)
With OutMail
.To = Tabelle1.Range("K" & CustRow).Value
.Subject = "Hallo, " & Tabelle1.Range("F" & CustRow).Value & "Test Test Test"
.Body = "Hallo, " & Tabelle1.Range("F" & CustRow).Value & "Test Test Test Test"
.Attachments.Add FileName
.Display
End With
Else:
WordDoc.PrintOut
WordDoc.Close
End If
Kill False '(FileName)
End If
Next CustRow
WordApp.Quit
'*~ cleanup after finishing
Set WordApp = Nothing
Set OutApp = Nothing
End With
End Sub
'*~
Function GetLastSentTemplate(sTemplate As String) As String
Dim lPrefixNumber As Long
If Len(sTemplate) > 0 Then
lPrefixNumber = Val(Left(sTemplate, InStr(sTemplate, ".") - 1))
If lPrefixNumber > 1 Then
GetLastSentTemplate = Replace(sTemplate, lPrefixNumber, lPrefixNumber - 1)
End If
End If
End Function