问如何在Outlook中对电子邮件进行分类然后再从Excel发送

EN

    Sub ContatoAtivo()

    Application.ScreenUpdating = False
    Application.DisplayAlerts = False

    Dim OutlookApp As Object
    Dim OutlookMail As Object
    Dim xTexto As String
    Dim Texto As String
    Dim X, Y, Z As Integer
    Dim Email As String
    Dim Assunto As String
    Dim Qtd As Integer
    Dim rng As Range

    Qtd = Planilha2.ListObjects(1).DataBodyRange.Rows.Count

    For X = 1 To 1
        Email = Planilha2.Cells(X + 6, 8).Value
        Subject = Planilha3.Cells(11, 1).Value

        If Email <> "" Then

            Set rng = Nothing
            Set rng = Planilha3.Range("E12:F22").SpecialCells(xlCellTypeVisible)

            Set OutlookApp = CreateObject("Outlook.Application")
            Set OutlookMail = OutlookApp.CreateItem(0)

            Text = "Test"

            With OutlookMail
                .To = "test.test@test.com.br"
                .CC = ""
                .BCC = ""
                .Subject = Planilha3.Range("A5").Value & " | " & Subject
                .HTMLBody = Text
                '.Display
                .Send

            End With

            Set OutlookMail = Nothing
            Set OutlookApp = Nothing

            Texto = ""

        End If

    Next X

    Application.DisplayAlerts = True
    Application.ScreenUpdating = True
End Sub