Sub Checking()
Dim OutlookApp As Object, SM As Object, r As Long, Cell As Range, Cnt As Integer
Dim Address As Variant, CC As Variant, Topic As Variant, Text As Variant
Cnt = 0
Application.EnableEvents = False
Application.Calculation = xlCalculationAutomatic

    With ThisWorkbook.Worksheets("Лист1")
'        Address = Range("M3").Value
'        CC = Range("M4").Value
'        Topic = Range("M5").Value
'        Text = Range("M6").Value
        r = .Cells(Rows.Count, 2).End(xlUp).Row
        If r > 1 Then
            For Each Cell In .Range("B2:B" & r)
                    If Cell.Value = "a" Then
                    
                        Address = Range("M3").Value
                        CC = Range("M4").Value
                        Topic = Range("M5").Value
                        Text = Range("M6").Value
                    
                        Set OutlookApp = CreateObject("Outlook.Application")
                        Set SM = OutlookApp.CreateItem(olMailItem)
                        'SM.SentOnBehalfOfName = "mail@example.ru" 'Поле "От", если нужен другой отправитель
                        SM.To = Address
                        SM.CC = CC
                        SM.Subject = Topic
                        On Error Resume Next
                        SM.Body = Text
                '       SM.Attachments.Add ("C:\Test.xls") 'Адрес вложения
                        SM.Display
                        Set SM = Nothing
                        Set OutlookApp = Nothing
                        Cnt = Cnt + 1
                        Cell.ClearContents
                        DoEvents
                    End If
            Next Cell
        End If
    End With
End Sub