Function LikeCell(cl As Range, rng As Range) As String
    For Each clr In rng.Cells
        For I = 0 To UBound(Split(cl, " "))
            If Split(cl, " ")(I) = clr Then
                If rez = Empty Then
                    rez = clr
                Else
                    rez = rez & ", " & clr
                End If
            End If
        Next
    Next
LikeCell = rez
End Function

Sub Отправка()
 
    Application.DisplayAlerts = False
    Dim OutlookApp As Object, SM As Object
    Dim cell As Range
    Set OutlookApp = CreateObject("Outlook.Application")
     
    Dim rng As Range
    Set rng = Intersect(ActiveSheet.Columns("E"), ActiveSheet.UsedRange)
    Set rng = rng.SpecialCells(xlCellTypeConstants)
     
    For Each cell In rng
         
        If cell.Value Like "*@*.*" Then
         
            Set SM = OutlookApp.CreateItem(olMailItem)
             
            With SM
                .To = cell.Value
                .Subject = "Привет"
                On Error Resume Next
                .Body = Activedocument.Content
                .HTMLBody = Activedocument.Content.Text
                .Display
                .Close
                .HTMLBody = "Добрый день." & .HTMLBody
                .Send
            End With
             
        End If
         
    Next
     
    Set SM = Nothing
    Set OutlookApp = Nothing
    Application.DisplayAlerts = True
End Sub
 

Sub Отправка()
 Application.DisplayAlerts = False
 Dim OutlookApp As Object, SM As Object
 Dim cell As Range
 Set OutlookApp = CreateObject("Outlook.Application")
 For Each cell In Columns("e").Cells.SpecialCells(xlCellTypeConstants)
 If cell.Value Like "?*@?*.?*.?*" And _
 Application.WorksheetFunction.CountA(cell) > 0 Then
 Set SM = OutlookApp.CreateItem(olMailItem)
 With SM
 SM.To = cell.Value
 SM.Subject = "Привет"
 On Error Resume Next
 SM.Body = Activedocument.Content
 SM.HTMLBody = Activedocument.Content.Text
 SM.Display
 SM.HTMLBody = "Как дела?" & SM.HTMLBody
 Set SM = Nothing
 Set OutlookApp = Nothing
 End With
 End If
 Next
End Sub 

Sub Создание_в_папку()
Application.DisplayAlerts = False
On Error Resume Next
folder$ = "C:\Users\Мой\Desktop\" & Sheets("Лист1").Range("E2").Value & "\"
MkDir folder$
Filename = [E2] & ".xlsx"
Err.Clear: ActiveWorkbook.SaveAs folder$ & "Сохранение в папку" & " " & Filename, xlOpenXMLWorkbook: DoEvents
If Err Then Exit Sub
Application.Quit
End Sub 

Sub Создание_папки()
Application.DisplayAlerts = False
On Error Resume Next
For Each oCell In Range([e2], [e2].End(xlUp))
    If Not IsEmpty(oCell) Then MkDir "C:\Users\Мой\Desktop\" & oCell
Next
ChDir "C:\Users\Мой\Desktop & oCell"
    ActiveWorkbook.SaveAs Filename:= _
        "C:\Users\Мой\Desktop\" & oCell & ".xlsx", FileFormat:= _
        xlOpenXMLWorkbook, CreateBackup:=False
End Sub
 

Sub Сохранение()
 Dim x As String
 strPath = "C:\Users\AVL\Desktop\Копилка"
 On Error Resume Next
 x = GetAttr(strPath) And 0
 If Err = 0 Then
   FileNameXls = strPath & "\" & "Сопоставимые АЗС" & " " & Sheets("Свод").Range("E2").Value & ".xls"
   ActiveWorkbook.SaveCopyAs Filename:=FileNameXls
  Else
   MsgBox "Папка " & strPath & " недоступна или не существует!", vbCritical
  End If
  Workbooks.Open (strPath & "\" & "Сопоставимые АЗС" & " " & Sheets("Свод").Range("E2").Value & ".xls")
    Dim iLinks As Variant, i&
    iLinks = ActiveWorkbook.LinkSources(xlExcelLinks)
    If Not IsEmpty(iLinks) Then
    For i = 1 To UBound(iLinks)
     ActiveWorkbook.BreakLink Name:=iLinks(i), Type:=xlExcelLinks
    Next i
    End If
    Dim oVBComponent As Object, lCountLines As Long
    If ActiveWorkbook.VBProject.Protection = 1 Then
      MsgBox "VBProject выбранной книги защищён." & vbCrLf & _
       "     Компоненты не будут удалены.", vbExclamation, "Отмена выполнения"
      Exit Sub
     End If
     For Each oVBComponent In ActiveWorkbook.VBProject.VBComponents
     On Error Resume Next
     With oVBComponent
      Select Case .Type
      Case 1
          .Collection.Remove oVBComponent
      Case 2    '
          .Collection.Remove oVBComponent
      Case 3
          .Collection.Remove oVBComponent
      Case 100
           lCountLines = .CodeModule.CountOfLines
           .CodeModule.DeleteLines 1, lCountLines
      End Select
      End With
     Next
     Set oVBComponent = Nothing
    ActiveWorkbook.Sheets("Свод").Visible = False
    ActiveWorkbook.Close = False
End Sub