Sub Pismo()
If ActiveSheet.Name = "СиК" Then
         adresat = "Сети и Коммуникации"
     ElseIf ActiveSheet.Name = "ВИТА" Then
         adresat = "ВИТА-сервис"
     Else
         adresat = ActiveSheet.Name
End If

'telo = "Добрый день!" & vbNewLine & _
'"-----" & vbNewLine & _
'"С уважением," & vbNewLine & _
'"Жаворонков Илья Владимирович" & vbNewLine & _
'"ОАО  ""ВымпелКом""" & vbNewLine & _
'"Группа обследования соединительных линий" & vbNewLine & _
'"вн: 133-85" & vbNewLine & _
'"гор: +7-909-991-33-85" & vbNewLine & _
'"моб: +7-964-639-19-50"
fpath = "C:\Users\izhavoronkov\Documents\ЗАЯВКИ\" & Month(Date) & "\" & ActiveSheet.Name & "\" & InputBox("№ заявки") & "\"
Set att = FilenamesCollection(fpath, "*.*")

For Each scel In Selection
If tema <> "" Then tema = tema & " " & scel Else tema = scel
Next
Call SendMail(adresat, tema, att)
End Sub

Sub SendMail(adresat, tema, att)
   On Error Resume Next
     Dim OutApp As Object
     Dim OutMail As Object
     Dim cell As Range
     Dim un As String
     un = Application.UserName
     'создаем новое пустое сообщение в Outlook
     Application.ScreenUpdating = False
     Set OutApp = CreateObject("Outlook.Application")
    
     OutApp.Session.Logon
     On Error GoTo cleanup
     Set OutMail = OutApp.CreateItem(0)
    
     'заполняем его адрес, тему и т.д.
     With OutMail
     
         .To = adresat
         .Subject = tema
        ' .Body = telo
        For i = 1 To att.Count
         .Attachments.Add att(i)
         Next i
         'вместо Send можно использовать Display, чтобы посмотреть сообщение перед отправкой
         .Display
     End With

     On Error GoTo 0
     Set OutMail = Nothing

cleanup:
     Set OutApp = Nothing
     Application.ScreenUpdating = True
End Sub

Function FilenamesCollection(ByVal FolderPath As String, Optional ByVal Mask As String = "", _
                    Optional ByVal SearchDeep As Long = 999) As Collection
     ' Получает в качестве параметра путь к папке FolderPath,
    ' маску имени искомых файлов Mask (будут отобраны только файлы с такой маской/расширением)
    ' и глубину поиска SearchDeep в подпапках (если SearchDeep=1, то подпапки не просматриваются).
    ' Возвращает коллекцию, содержащую полные пути найденных файлов
    ' (применяется рекурсивный вызов процедуры GetAllFileNamesUsingFSO)

     Set FilenamesCollection = New Collection    ' создаём пустую коллекцию
    Set FSO = CreateObject("Scripting.FileSystemObject")    ' создаём экземпляр FileSystemObject
    GetAllFileNamesUsingFSO FolderPath, Mask, FSO, FilenamesCollection, SearchDeep ' поиск
    Set FSO = Nothing: Application.StatusBar = False    ' очистка строки состояния Excel
End Function

Function GetAllFileNamesUsingFSO(ByVal FolderPath As String, ByVal Mask As String, ByRef FSO, _
                    ByRef FileNamesColl As Collection, ByVal SearchDeep As Long)
     ' перебирает все файлы и подпапки в папке FolderPath, используя объект FSO
    ' перебор папок осуществляется в том случае, если SearchDeep > 1
    ' добавляет пути найденных файлов в коллекцию FileNamesColl
    On Error Resume Next: Set curfold = FSO.GetFolder(FolderPath)
     If Not curfold Is Nothing Then    ' если удалось получить доступ к папке

         ' раскомментируйте эту строку для вывода пути к просматриваемой
        ' в текущий момент папке в строку состояния Excel
        ' Application.StatusBar = "Поиск в папке: " & FolderPath

         For Each fil In curfold.Files    ' перебираем все файлы в папке FolderPath
            If fil.Name Like "*" & Mask Then FileNamesColl.Add fil.Path
         Next
         SearchDeep = SearchDeep - 1    ' уменьшаем глубину поиска в подпапках
        If SearchDeep Then    ' если надо искать глубже
            For Each sfol In curfold.SubFolders    ' перебираем все подпапки в папке FolderPath
                GetAllFileNamesUsingFSO sfol.Path, Mask, FSO, FileNamesColl, SearchDeep
             Next
         End If
         Set fil = Nothing: Set curfold = Nothing    ' очищаем переменные
    End If
End Function