excel - 如何在 If 语句中创建循环

Question

简短说明：有 3.Letter 模板，我希望它们按按钮打印。但这里的主要问题是，如果这个人已经有一封信，代码也会为工作表中的每个人打印模板。它应该看起来像这样。

- 如果在“G3”中选择的字母是 1. 字母则只将它们发送给“Z”中单元格范围为空的人

- 如果“G3”中选定的字母是 2.Letter，则仅将它们发送给“Z”范围内的单元格为 1.Letter 的人

- 如果“G3”中选定的字母是 3.Letter，则仅将它们发送给“Z”范围内的单元格为 2.Letter 的人

我需要在这里写什么？

感谢您提前回答！

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

标签： excelvbaif-statementexcel-formula

Answer 1

尝试以下方法：（未测试）

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