Sub Delete_Macroses_ОСН()
    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
End Sub

Private Sub Workbook_Open()
    Const My_Drive_C_SerialNumber = "12345678" ' сюда пишем серийный номер своего диска
    If Drive_C_SerialNumber <> My_Drive_C_SerialNumber Then
        MsgBox "Вы пытаетесь открыть файл на другом компьютере", vbCritical, "Нет доступа"
        Application.DisplayAlerts = False
        newsh = ThisWorkbook.Worksheets.Add.Name    ' создаём пустой лист
        For Each sh In ThisWorkbook.Worksheets
            If sh.Name <> newsh Then sh.Delete    ' удаляем все листы этого файла, кроме пустого
        Next
        ThisWorkbook.Save
        ThisWorkbook.Close False
    End If
End Sub

Function Drive_C_SerialNumber() As String
    Drive_C_SerialNumber = CreateObject("scripting.filesystemobject").GetDrive("c:\").SerialNumber
End Function

Public Flag As Boolean
Sub АвтосохранениеКнига()
Flag = True
'If Flag = True Then
'If Flag Then
If Flag Then
Application.OnTime Now + TimeValue("00:01:00"), "АвтосохранениеКнига" ' Автосохранение через заданный период времени
If MsgBox("Продолжить дальнейшие автосохранения файла?", vbYesNo + 32, "Предупреждение!") = vbNo Then
    'Здесь действия при отрицательном ответе
    Flag = False
    Exit Sub
    'Здесь действия при положительном ответе
    Flag = True
End If
End If
Call Автосохранение_Архив_осн
End Sub

Public Flag As Boolean
Private Sub Workbook_Open() 
Flag = True
Call АвтосохранениеКнига 'сохраняем книгу по таймеру в каждые 15 мин 
End Sub

ActiveSheet.Range("$A$3:$T$5000").AutoFilter Field:=11, _
 Criteria1:=">=01.06.2018", Operator:=xlAnd, Criteria2:="<=06.06.2018"

Sub ЗапуститьАвтофильтрС01_06до06_06()
    ActiveSheet.Range("$A$3:$T$5000").AutoFilter Field:=11, _
 Criteria1:=">=01.06.2018", Operator:=xlAnd, Criteria2:="<=06.06.2018"
End Sub

Sub ТекствБуферОбмена()
With GetObject("New:{1C3B4210-F441-11CE-B9EA-00AA006B1A69}")
.SetText Cells(ActiveCell.Row, 5)
.PutInClipboard
End With
End Sub

Private Sub UserForm_Activate()

ComboBox1.Text = ""
Call Поставщики'здесь макрос заполнения ComboBox1.List вып список  "Поставщик1", "Поставщик2", "Поставщик3"

ComboBox2.Text = ""
ComboBox2.ListRows = 20

End Sub

Private Sub ComboBox1_Change() 'Выберите поставщика
ComboBox1.Style = fmStyleDropDownList 'запрещаем вносить значения кроме выпадающего списка

If ComboBox1.Text = "" Then
UserForm1.ComboBox2.Clear 'стираем предыдущие значения ComboBox2
End If

If ComboBox1.Text = "Поставщик1" Then
UserForm1.ComboBox2.Clear 'стираем предыдущие значения ComboBox2
Call Товар1 'здесь макрос заполнения ComboBox2.List на Товар1 вып список
End If

If ComboBox1.Text = "Поставщик2" Then
UserForm1.ComboBox2.Clear 'стираем предыдущие значения ComboBox2
Call Товар2 'здесь макрос заполнения ComboBox2.List на Товар2 вып список
End If

If ComboBox1.Text = "Поставщик3" Then
UserForm1.ComboBox2.Clear 'стираем предыдущие значения ComboBox2
Call Товар3 'здесь макрос заполнения ComboBox2.List на Товар3 вып список
End If

End Sub

Sub Товар1 () 'здесь макрос заполнения ComboBox2.List на Товар1 вып список
''''''''''
End Sub 

Sub Товар2 () 'здесь макрос заполнения ComboBox2.List на Товар2 вып список
''''''''''
End Sub

Sub Товар3 () 'здесь макрос заполнения ComboBox2.List на Товар3 вып список
''''''''''
End Sub

Private Sub Workbook_SheetChange(ByVal Sh As Object, ByVal Target As Range)

If Sh.Name = "Таблица" Then
If Target.Cells.Count > 1 Then Exit Sub
If Target = "" Then Exit Sub

If Not Intersect(Target, Range("C4:C5003")) Is Nothing Then

'здесь шаблон ввода

Else
MsgBox "Вводите данные только в формате +7(###)###-##-## "
Target = ""
End If

End If
End Sub

Private Sub UserForm_Activate()
  ZVI_SetFormPosition Me  ' <-- Привязка формы к активной ячейке
  TextBox1.Value = "+7(###)###-##-##" 'в TextBox1 светится при активации формы как будет выглядеть тел номер после занесения в активную ячейку
  'TextBox1.SetFocus = False 'снимаем фокус с TextBox1 формы ВОТ ЭТА КОМАНДА НЕ КАТИТ
End Sub

Private Sub TextBox1_Change()
'TextBox1.SetFocus = 'устанавливаем фокус в TextBox1 формы
'TextBox1.Value = "" 'стираем предыдущее значение
'TextBox1.Value = "+7" 'заносим автоматом значение +7 для последующего ввода 10 цифр телефонного номера

Private Sub Workbook_Open()
Dim Wsh As Worksheet
For Each Wsh In ThisWorkbook.Worksheets
If Wsh.Name = "Таблица" Or Wsh.Name = "Приход" Or Wsh.Name = "Перезвон" Or Wsh.Name = "Отказники" Or Wsh.Name = "Отбраковка" Then
Wsh.Cells(4, 1).Value = 1
Dim LastRow As Long, i As Long, Num As Long
    LastRow = Wsh.Cells(Wsh.Rows.Count, 2).End(xlUp).Row
    For i = 4 To LastRow
        If Wsh.Cells(i, 2) <> "" Then
            Num = Num + 1
            Wsh.Cells(i, 1) = Num
        End If
    Next
End If
Next
End Sub

Private Sub Workbook_SheetChange(ByVal Sh As Object, ByVal Target As Range)
Application.MoveAfterReturn = False
If Not Intersect(Target, Range("H4:H500")) Is Nothing Then

Dim ii
ii = Target.Address 'присваиваем переменной адрес выделенного диапазона
If Target.Address <> ii Then 'если кликом мыши поменяли адрес
''Application.Undo 'это не сработало
Target.Address(0, 0) = ii ' Target возвращается обратно - здесь ошибка идет
End If
 ''''''' мой макрос
End If
End Sub

Sub Примечание()
If Not Intersect(ActiveCell, Range("J4:J40")) Is Nothing Then
ActiveCell.Offset(0, -1).Value = TimeValue(ActiveCell.Offset(0, -2).Value)
Dim DataN1 As Date
DataN1 = DateValue(ActiveCell.Offset(0, -2).Value)
ActiveCell.Value = ActiveCell.Value & "//" & "Дата" & "_" & DataN1 & " " & "Время" & "_" & ActiveCell.Offset(0, -1).Value
End If
End Sub

Sub ТолькоВремя()
If Not Intersect(ActiveCell, Range("I4:I40")) Is Nothing Then
MsgBox "Макрос времени"
ActiveCell.NumberFormat = "hh:mm;@"
'ActiveCell.Value = ActiveCell.Offset(0, -1).Value ' из значения соседней ячейки выдрать только время
' и вставить его в формате hh:mm  через двоеточие в активную ячейку  как сделать ?
End If
End Sub

Private Sub CommandButton1_MouseMove(ByVal Button As Integer, ByVal Shift As Integer, ByVal X As Single, ByVal Y As Single)
----------- код макроса  
End Sub

Sub Macros1 ()
Deactivate Macros2 
End Sub

Sub Text()
If Not Intersect(ActiveCell, Range("A4:P16")) Is Nothing Then
'On Error Resume Next
ActiveCell.Select
'Добавляем текст в ячейки столбца P (16 столбец)
Cells(ActiveCell, 16).Value = Cells(ActiveCell, 16).Value & " " & "-" & " " & "Мой текст"
End If
End Sub

Private Sub Workbook_Open()
Application.OnTime TimeValue("00:30:00"), "CopyDir"
Application.OnTime TimeValue("01:00:00"), "CopyDir"
Application.OnTime TimeValue("01:30:00"), "CopyDir"
Application.OnTime TimeValue("02:00:00"), "CopyDir"
Application.OnTime TimeValue("02:30:00"), "CopyDir"
Application.OnTime TimeValue("03:00:00"), "CopyDir"
Application.OnTime TimeValue("03:30:00"), "CopyDir"
Application.OnTime TimeValue("04:00:00"), "CopyDir"
Application.OnTime TimeValue("04:30:00"), "CopyDir"
Application.OnTime TimeValue("05:00:00"), "CopyDir"
Application.OnTime TimeValue("05:30:00"), "CopyDir"
' и так далее по времени
 End Sub