Sub ТБ()          ' отправка всех писем с невыполнеными заданиями
Dim i As IntegerPassword = 40919Worksheets("Справочник").Activate     
If Cells(2, 6).Value = Password Then                
Application.ScreenUpdating = False                
Application.DisplayAlerts = False        
        Worksheets("Меры").Activate                
Dim rng As Range: Set rng = Application.Range("Меры!K:K")                
Dim cell As Range                
For Each cell In rng.Cells                
a = cell.Value                         
If (cell.Value = "НАПРАВЛЯТЬ") Then '(cell.Value = "НАПРАВЛЯТЬ")And cell.Offset(0, 16).Value <> "" Then                                  
Call MakeEMail(cell.Row)                     
             cell.Offset(, 2).Value = Now                        
End If                                    
   Next cell
   Application.ScreenUpdating = True         
   Application.DisplayAlerts = True          
  MsgBox ("Напоминания по мерам отправлены.")   
  Else       MsgBox "Неверный пароль!  " & vbCrLf & "Сообщения НЕ отправлены. ", vbCritical, "Ошибка."     
End If
End Sub

For Each cell In Columns("K").Cells.SpecialCells(xlCellTypeFormulas, xlTextValues)
                        If (Cells(i, 11) Like "НАПРАВЛЯТЬ") Then '(cell.Value Like "НАПРАВЛЯТЬ")And cell.Offset(0, 16).Value <> "" Then
                                 Call MakeEMail(i)
                                 Worksheets("Меры").Activate
                                 Cells(i, 13).Value = Now
                       End If
                       cell.Offset(1, 0).Value = cell.Offset(1, 0).Value
               i = i + 1
               Next

           Application.ScreenUpdating = True
           Application.DisplayAlerts = True
           MsgBox ("Напоминания по мерам отправлены.")
    Else
      MsgBox "Неверный пароль!  " & vbCrLf & "Сообщения НЕ отправлены. ", vbCritical, "Ошибка."
    End If