Private
WithEvents DeletedItemsFolder As Outlook.Folder

Private
WithEvents DeletedItemsItems As Outlook.Items

Private Sub
Application_Startup()
    Dim outlookApp As Outlook.Application
    Set outlookApp = Outlook.Application
    ' Получаем папку "Корзина"
    Dim mailbox As Outlook.MAPIFolder
    Set mailbox =
outlookApp.GetNamespace("MAPI").GetDefaultFolder(olFolderDeletedItems)
    Set DeletedItemsFolder = mailbox
    Set DeletedItemsItems =
DeletedItemsFolder.Items
End Sub

Private Sub
DeletedItemsItems_ItemAdd(ByVal Item As Object)
    On Error Resume Next
    ' Помечаем
добавленный элемент как прочитанный
    Item.UnRead =
False
    ' Очищаем память
    Set Item = Nothing
End Sub

Function kaktext(r As Range) As String
kaktext = r.Text
End Function

Private Sub Workbook_SheetFollowHyperlink(ByVal sh As Object, ByVal Target As Hyperlink)  
If Target.Address <> "" Then Exit Sub 'внешняя гиперссылка  
Range(Target.SubAddress).Parent.Visible = xlSheetVisible: sh.Visible = xlSheetHidden  
End Sub

ActiveWorkbook.SaveAs Filename:=p & "\" & "Отчет за " & Format(DateSerial(Year(Now), Month(Now) - 1, 1), "[$-ru-RU-x-nomlower]mmmm yyyy;@") & "" & ".xlsx", FileFormat:=xlOpenXMLWorkbook

Sub Параметры()
For Each xWorksheet In ActiveWorkbook.Worksheets
    With xWorksheet.PageSetup
        .FitToPagesWide = 1
        .Orientation = xlLandscape
        .LeftMargin = Application.InchesToPoints(0.196850393700787)
        .RightMargin = Application.InchesToPoints(0.196850393700787)
        .TopMargin = Application.InchesToPoints(0.196850393700787)
        .BottomMargin = Application.InchesToPoints(0.196850393700787)
        .HeaderMargin = Application.InchesToPoints(0)
        .FooterMargin = Application.InchesToPoints(0)
        .CenterHorizontally = True
        .PrintTitleRows = "$5:$7"
    End With
Next xWorksheet
End Sub

=СУММЕСЛИ('[Книга1.xlsb]Лист1'!$I$2:$I$4492;N6;'[Книга1.xlsb]Лист1'!$Y$2:$Y$4492)

Set Данные1 = Книга1.Лист1

=СУММЕСЛИ('Данные1'!$I$2:$I$4492;N6;'Данные1'!$Y$2:$Y$4492)

p = ActiveWorkbook.Path
    Sheets("Лист для сохранения").Copy
     ActiveWorkbook.SaveAs Filename:=p & "\" & Format(Now(), "mm/yyyy") & " " & "Лист для сохранения.xlsx", FileFormat:=xlOpenXMLWorkbook
     Sheets(1).Activate
     ActiveSheet.Shapes.Range(Array("Button 1")).Delete

ActiveWindow.Close

Sub Вставка_строк()
Dim i As Long, iLastRow As Long, col1 As Range
    With Application
        .ScreenUpdating = False
        Set col1 = Application.InputBox(Prompt:="Выберите столбец", Type:=8)'выбор столбца
        iLastRow = Cells(Rows.Count, 5).End(xlUp).Row 'вместо номера столбца хочу указать переменную столбца, но вылетает ошибка
        If iLastRow = 1 Then
            MsgBox "Нет данных в выбранном столбце", vbExclamation, "Ошибка"
            Exit Sub
        End If
            For i = iLastRow To 5 Step -1
                If Cells(i, 5) <> Cells(i - 1, 5) Then
                    Cells(i, 1).EntireRow.Insert
                    i = i - 1
                End If
            Next i
        .ScreenUpdating = True
    End With
End Sub

Worksheets("Схема").Range("D" & i + 3) = Application.WorksheetFunction.SumIf(.Range("A5:A200" & c2), rst(0), .Range("C5:C200" & c2) '1 вариант

Worksheets("Схема").Range("D" & i + 3) = Application.WorksheetFunction.SumIf(.Range("A5:A200" & c2), rst(0), .Range("F5:F200" & c2) '2 вариант

Sub SplitSheets2()
    Dim s As Worksheet
    Dim wb as Workbook
    Set wb = ActiveWorkbook
    For Each s In wb.Worksheets                                'проходим во всем листам активной книги
        s.Copy                                                 'сохраняем лист как новый файл
        ActiveWorkbook.SaveAs wb.Path & "\" & s.Name & ".xls"  'сохраняем файл
    Next
End Sub

Sub SplitSheets2()
    Dim s As Worksheet
    Dim wb as Workbook
    Set wb = ActiveWorkbook
    For Each s In wb.Worksheets                                'проходим во всем листам активной книги
    s.ExportAsFixedFormat Type:=xlTypePDF, Quality:=xlQualityMinimum, _        IncludeDocProperties:=True, IgnorePrintAreas:=False, OpenAfterPublish:= True
        s.Copy                                                 'сохраняем лист как новый файл
        ActiveWorkbook.SaveAs wb.Path & "\" & s.Name & ".xls"  'сохраняем файл
    Next
End Sub