出错时进入循环

Question

我正在尝试创建一个循环来查看客户列表，如果该客户有报告，请通过电子邮件向该客户发送报告。

我需要的是一个 On Error 语句，它允许跳过没有报告的客户，并允许脚本继续处理下一个客户，直到客户列表的末尾。

我目前的 On Error 语句，在所有客户循环通过后卡住，并继续在 On Error 语句中循环。

任何帮助将不胜感激！！！

sub test()

a = 2

Check:

  Do Until UniqueBuyer.Range("A" & a).Value = ""

 On Error GoTo ErrHandler:

    Sheets(UniqueBuyer.Range("A" & a).Value).Activate

        ActiveSheet.ExportAsFixedFormat Type:=xlTypePDF, Filename:= _
        FolderLocation & FolderName & "\" & _
        UniqueBuyer.Range("A" & a).Value & ".pdf" _
        , Quality:=xlQualityStandard, IncludeDocProperties:=True, IgnorePrintAreas _
        :=Flase, OpenAfterPublish:=False
        PDFFile = FolderLocation & FolderName & "\" & _
        UniqueBuyer.Range("A" & a).Value & ".pdf"

            Set OutLookApp = CreateObject("Outlook.Application")
            Set OutlookMail = OutLookApp.createItem(0)
            CombinedEmail = ""
            'Clear variable - LK
            On Error Resume Next
            'Display email and specify To, Subject, etc
            With OutlookMail

                .Display
                c = 4
                Do Until UniqueBuyer.Cells(a, c).Value = ""
                AdditionalEmail = UniqueBuyer.Cells(a, c)
                CombinedEmail = CombinedEmail & ";" & AdditionalEmail
                .to = CombinedEmail
                c = c + 1
                Loop

                .cc = ""
                .BCC = ""
                .Subject = "Weekly Wooltrade Summary " & Left(Master.Range("X2"), 3)
                .Body = ""
                .Attachments.Add PDFFile
                '.Send

             End With

            On Error GoTo 0

a = a + 1

Loop
Exit Sub

ErrHandler:

a = a + 1
GoTo Check

 End Sub

Answer 1

On Error GoTo 方式几乎不可行：您最好检查任何可能的错误并处理它

此外，您最好只为所有需要的电子邮件实例化一个 Outlook 应用程序

终于出现了一些错别字（Flase -> False）

以下是对上述代码的可能（已注释）重构：

Option Explicit

Sub test()
    Dim UniqueBuyer As Worksheet, Master As Worksheet
    Dim FolderLocation As String, FolderName As String, PDFFile As String
    Dim OutLookApp As Object
    Dim cell As Range

    FolderLocation = "C:\Users\...\" '<--| change it to your actual folder location
    FolderName = "Test" '<--| change it to your actual folder name

    Set UniqueBuyer = Worksheets("UniqueBuyer") '<--| change "UniqueBuyer" to your actual Unique Buyer sheet name
    Set Master = Worksheets("Master") '<--| change "Master" to your actual Master sheet name

    Set OutLookApp = CreateObject("Outlook.Application") '<--| set one Outlook application outside the loop

    With UniqueBuyer '<--| reference your "Unique Buyer" sheet
        For Each cell In .Range("A2", .Cells(.Rows.Count, 1).End(xlUp)).SpecialCells(xlCellTypeConstants, xlTextValues) '<--| loop through its column A cells with constant (i.e. not from formulas) text content from row 2 down to last not empty one
            PDFFile = FolderLocation & FolderName & "\" & cell.Value & ".pdf" '<--| build your PDF file name
            With .Range(cell.Offset(, 3), cell.Offset(, 3).End(xlToRight)) '<--| reference current buyer cells from column 4 rightwards
                If WorksheetFunction.CountA(.Cells) > 0 Then '<--| if any not-blank cells in referenced ones
                    If OKSheetAndExportToPDF(cell.Value, PDFFile) Then '<--| if successfully found current buyer sheet and exported it to PDF
                        'Display email and specify To, Subject, etc
                        With OutLookApp.createItem(0) '<--| create a new mail item and reference it
                            .Display
                            .to = GetCombinedEmails(.SpecialCells(xlCellTypeConstants, xlTextValues)) '<--| get emails string from currently referenced cells with some constant text value
                            .cc = ""
                            .BCC = ""
                            .Subject = "Weekly Wooltrade Summary " & Left(Master.Range("X2"), 3)
                            .Body = ""
                            .Attachments.Add PDFFile
                            '.Send
                        End With
                    End If
                End If
            End With
        Next
    End With

    Set OutLookApp = Nothing
End Sub

Function GetCombinedEmails(rng As Range) As String
    Dim cell As Range
    With rng
        If .Count = 1 Then
            GetCombinedEmails = .Value
        Else
            GetCombinedEmails = Join(Application.Transpose(Application.Transpose(.Value)), ";") '<--| join all found consecutive email addresses in one string
        End If
    End With
End Function

Function OKSheetAndExportToPDF(shtName As String, PDFFile As String) As Boolean
    On Error GoTo ExitFunction
    With Worksheets(shtName)
        .ExportAsFixedFormat Type:=xlTypePDF, _
            Filename:=PDFFile, _
            Quality:=xlQualityStandard, _
            IncludeDocProperties:=True, _
            IgnorePrintAreas:=False, _
            OpenAfterPublish:=False
        OKSheetAndExportToPDF = True
    End With
ExitFunction:
End Function