Sub SendFile()
Dim OutlookApp As Object
Dim OutlookMail As Object
' Создание нового экземпляра приложения Outlook
Set OutlookApp = CreateObject("Outlook.Application")
' Создание нового электронного письма
Set OutlookMail = OutlookApp.CreateItem(0)
' Определение параметров письма
With OutlookMail
.To = "адрес_получателя"
' .CC = "адрес_с_копией"
' .BCC = "адрес_с_скрытой_копией"
.Subject = "Тема_письма"
.Body = "Текст_письма"
.Attachments.Add Application.GetOpenFilename
' .Send
End With
' Освобождение ресурсов
Set OutlookMail = Nothing
Set OutlookApp = Nothing
End Sub

Option Explicit
'удаление столбца из всех файлов в папке
Sub Get_All_File_from_Folder()
    Dim sFolder As String, sFiles As String
    Dim wb As Workbook
    'диалог запроса выбора папки с файлами
    With Application.FileDialog(msoFileDialogFolderPicker)
        If .Show = False Then Exit Sub
        sFolder = .SelectedItems(1)
    End With
    sFolder = sFolder & IIf(Right(sFolder, 1) = Application.PathSeparator, "", Application.PathSeparator)
    'отключаем обновление экрана, чтобы наши действия не мелькали
   Application.ScreenUpdating = False
    sFiles = Dir(sFolder & "*.xls*")
    Do While sFiles <> ""
        'открываем книгу
        Set wb = Application.Workbooks.Open(sFolder & sFiles)
        'действия с файлом
        'удаление столбца I : N
        wb.Sheets(1).Range("I:N").Delete
        'Закрываем книгу с сохранением изменений
        wb.Close True 'если поставить False - книга будет закрыта без сохранения
        sFiles = Dir
    Loop
    'возвращаем ранее отключенное обновление экрана
   Application.ScreenUpdating = True
End Sub

Sub Itog()
'макрос вставки итога в виде картинки из таблицы
     Dim fio As Variant
Dim list As Worksheet
Set list = ActiveSheet

    fio = ActiveSheet.Range("A2")
    Application.Workbooks("2023.xlsx").Activate
'фильтр по значению
    Sheets("ОКТЯБРЬ").Range("$B$2:$R$103").AutoFilter Field:=1, Criteria1:=fio
'выделение и копирование   
    Sheets("ОКТЯБРЬ").Range("$B$2:$R$103").Select
    Selection.SpecialCells(xlCellTypeVisible).Select
    Selection.Copy
'вставка рисунка в активный лист  
    list.Pictures.Paste.Select
'изменение размера и положения   
    Selection.ShapeRange.ScaleWidth 0.919254124, msoFalse, msoScaleFromTopLeft
       
End Sub

 Selection.ShapeRange.ScaleWidth 0.919254124, msoFalse, msoScaleFromTopLeft

SM.HTMLBody = "Текст1" & vbNewLine & "Текст2" & SM.HTMLBody

Sub Макрос3()
'
' Макрос3 Макрос
'
' Сочетание клавиш: Ctrl+f
'
    ActiveCell.Offset(1, 0).Range("A1").Select
    ActiveSheet.Pictures.Paste.Select
    ActiveSheet.Shapes.Range(Array("Picture 3")).Select
End Sub

ActiveSheet.Shapes.Range(Array("Picture 3")).Select

 Set wb = ActiveWorkbook
    sAttachment = Application.GetSaveAsFilename(InitialFileName:=wb.Path & "\" & ActiveSheet.Name & ".xlsx")
    ActiveSheet.Copy
    With ActiveWorkbook
        .sToSavePath = Application.GetSaveAsFilename(InitialFileName:=sAttachment)
        .SaveAs sAttachment, xlOpenXMLWorkbook
        .Close False
    End With
    Application.DisplayAlerts = True

 .sToSavePath = Application.GetSaveAsFilename(InitialFileName:=wb.Path & "\" & ActiveSheet.Name & ".xlsx") 

Sub EXP() 'Макрос сохранения листа и отправки

    Dim objOutlookApp As Object, objMail As Object
    Dim wb As Workbook
    Dim sAttachment As String
  
    Application.ScreenUpdating = False
    On Error Resume Next
    'пробуем подключиться к Outlook, если он уже открыт
    Set objOutlookApp = GetObject(, "Outlook.Application")
    Err.Clear 'Outlook закрыт, очищаем ошибку
    If objOutlookApp Is Nothing Then
        Set objOutlookApp = CreateObject("Outlook.Application")
    End If
 
    Set objMail = objOutlookApp.CreateItem(0)   'создаем новое сообщение
    'если не получилось создать приложение или экземпляр сообщения - выходим
    If Err.Number <> 0 Then Set objOutlookApp = Nothing: Set objMail = Nothing: Exit Sub
     
    Application.DisplayAlerts = False
    Set wb = ActiveWorkbook
    sAttachment = wb.Path & "\" & ActiveSheet.Name & ".xlsx"
    ActiveSheet.Copy
    With ActiveWorkbook
 .sToSave = Application.GetSaveAsFilename(InitialFileName:=wb.Path & "\" & ActiveSheet.Name & ".xlsx")
        .SaveAs sAttachment, xlOpenXMLWorkbook
        .Close False
    End With
    Application.DisplayAlerts = True
    'создаем сообщение
    With objMail
        .To = Range("A3").Value 'адрес получателя
        .Subject = ActiveSheet.Name 'тема сообщения
        'добавляем вложение, если файл по указанному пути существует(dir проверяет это)
        If sAttachment <> "" Then
            If Dir(sAttachment, 16) <> "" Then
                .Attachments.Add sAttachment 'просто вложение
            End If
        End If
        .Display 'если необходимо просмотреть сообщение, а не отправлять без просмотра
    End With
  
    Set objOutlookApp = Nothing: Set objMail = Nothing
    Application.ScreenUpdating = True
End Sub

Sub SaveSheet()
     Application.DisplayAlerts = False
    Set wb = ActiveWorkbook
    ActiveSheet.Copy
    With ActiveWorkbook
     
    .SaveAs wb.Path & "\" & .ActiveSheet.Name & ".xlsx", xlOpenXMLWorkbook
    .Close False
        End With
    ActiveWorkbook.SendMail Recipients:="new@adres.ru", Subject:="Тема письма"
    Application.DisplayAlerts = True
       
    
End Sub

Sub SohrList22()
Dim CurrentWin As Window
Dim VremWin As Window
Set CurrentWin = ActiveWindow
Set VremWin = ActiveWorkbook.NewWindow
CurrentWin.ActiveSheet.Copy
VremWin.Close
Path = ThisWorkbook.Path & "\"
ThisWorkbook.SaveAs (Path & ActiveSheet.Name)
End Sub