У меня возникли проблемы с зацикливанием этого кода для просмотра набора адресов электронной почты и имен для отправки на электронную почту в зависимости от поля сводки

Question

введите описание изображения здесь Я пытаюсь провести этот цикл через набор электронных писем, где «Пример» ссылается на конкретное электронное письмо на другом листе и отправляет соответственно. Код ниже, пожалуйста, дайте мне знать, если вы можете помочь, спасибо!

    Sub EmailFund1()

        Dim r As Range
        Set r = Selection

        Range("B1").Select
        Sheet2.PivotTables("PivotTable2").PivotFields("Format").ClearAllFilters
        Sheet2.PivotTables("PivotTable2").PivotFields("Format").CurrentPage = "Example"

        ActiveWorkbook.EnvelopeVisible = True

        With r.Parent.MailEnvelope.Item
            .To = "enteremailhere"
            .cc = ""
            .bcc = ""
            .Subject = "EnterSubjectHere"

            .Send

        End With
    End Sub

Хотите, чтобы код циклически проходил по длинному списку полей в сводных таблицах и отправлялся на конкретное электронное письмо в зависимости от выбранного фильтра.

введите описание изображения здесь

Answer 1

Вы можете попробовать это:

    Sub EmailFund1()

        Dim r As Range
        Dim SItm As SlicerItem
        Dim SItm2 As SlicerItem
        Dim cel As Range
        Dim strEmail As String
        Dim strSubject As String
        Dim intI As Integer
        Dim intJ As Integer
        Dim objRow As Range
        Dim blnExit As Boolean

        Set r = Worksheets("Fund Pivot").Range("B1")
        r.Select

        For Each objRow In Worksheets("VBA Tab").Rows
            blnExit = False

            ActiveWorkbook.EnvelopeVisible = True

            For Each SItm In ActiveWorkbook.SlicerCaches("Slicer_Fund_s").SlicerItems


                SItm.Selected = True
                For Each SItm2 In ActiveWorkbook.SlicerCaches("Slicer_Fund_s").SlicerItems
                    If SItm.Name <> SItm2.Name Then
                        SItm2.Selected = False
                    End If
                Next


                strEmail = LCase(Trim(objRow.Cells(, 2).Value))
                strSubject = UCase(Trim(objRow.Cells(, 1).Value))

                If UCase(Trim(SItm.Name)) = strSubject Then

                    With r.Parent.MailEnvelope.Item
                        .to = strEmail
                        .cc = ""
                        .bcc = ""
                        .Subject = strSubject

                        .send

                    End With

                   'We have found the email, we can exit the for loop.
                   Exit For
               ElseIf Len(strSubject) < 1 Then
                   'Reached the end. exit loop
                   blnExit = True
               End If
           Next

           If blnExit Then Exit For
        Next

        Set r = Nothing

    End Sub