Private Sub ВставкаПК_Click()
Application.ScreenUpdating = False
Sheets("П-К").Select
    Range("A1").Select
    ActiveSheet.Paste
    Rows("1:6").Delete Shift:=xlUp
    Rows("4:4").Delete Shift:=xlUp
    Rows("1:3").Copy
    Sheets("П-С").Select
    Range("A1").Select
    ActiveSheet.Paste
    Sheets("П-Т").Select
    Range("A1").Select
    ActiveSheet.Paste
    Sheets("П-К").Select
    Range("A4:C4").Select
    Cells.Find(What:="Тарабукина Магазин", After:=ActiveCell, LookIn:= _
        xlFormulas, LookAt:=xlPart, SearchOrder:=xlByRows, SearchDirection:= _
        xlNext, MatchCase:=False, SearchFormat:=False).Activate
        Selection.End(xlToRight).Select
    Selection.End(xlToRight).Select
    Range(Selection, Selection.End(xlToLeft)).Select
    Range(Selection, Selection.End(xlToLeft)).Select
    Range(Selection, Selection.End(xlDown)).Select
    Application.CutCopyMode = False
    Selection.Cut
    Sheets("П-Т").Select
    Range("A4").Select
    ActiveSheet.Paste
    Sheets("П-К").Select
    Range("A4:C4").Select
    Cells.Find(What:="Строителей Магазин", After:=ActiveCell, LookIn:= _
        xlFormulas, LookAt:=xlPart, SearchOrder:=xlByRows, SearchDirection:= _
        xlNext, MatchCase:=False, SearchFormat:=False).Activate
    Selection.End(xlToRight).Select
    Selection.End(xlToRight).Select
    Range(Selection, Selection.End(xlToLeft)).Select
    Range(Selection, Selection.End(xlToLeft)).Select
    Range(Selection, Selection.End(xlDown)).Select
    Selection.Cut
    Sheets("П-С").Select
    Range("A4").Select
    ActiveSheet.Paste
    Columns("B:B").ColumnWidth = 70.01
    Columns("D:N").ColumnWidth = 9.14
    Cells.Select
    Cells.EntireRow.AutoFit
    Sheets("П-К").Select
    Columns("B:B").ColumnWidth = 70.01
    Columns("D:N").ColumnWidth = 9.14
    Cells.Select
    Range("A1780").Activate
    Cells.EntireRow.AutoFit
    Range("A4:C4").Select
    Sheets("П-С").Select
    Range("A4:C4").Select
    Sheets("П-Т").Select
    Columns("B:B").ColumnWidth = 70.01
    Columns("D:N").ColumnWidth = 9.14
    Cells.Select
    Cells.EntireRow.AutoFit
    Range("A4:C4").Select
    Sheets("П-К").Select
Application.ScreenUpdating = True
MsgBox "Продажи вставлены и распределены по магазинам!!!"
End Sub

Private Sub CommandButton1_Click()
     Application.ScreenUpdating = False
ActiveWorkbook.SaveAs ("\\KVCEN05-FILE001.officekiev.fozzy.lan\Shared Documents\KR\EVPAT8\COMMON\Переоценка\2016\Май\" & Date & ".xls")
    Application.ScreenUpdating = True

Sub Zapusk_Excel_iz_Outlook2()Dim objXls As Object
Set objXls = CreateObject("Excel.Application")
objXls.Workbooks.Open "D:\мингачёв\Файл переоценка (Крым).xlsm" 'укажите путь и имя существующего файла
objXls.Application.Visible = True
Set objXls = Nothing
End Sub

Private Sub Workbook_Open()
MenuForm.Show
End Sub

Private Sub ComboBox1_Change()
Application.ScreenUpdating = False
   Dim iSotrud As String
    On Error Resume Next
    iArt = Me.ComboBox1.List(Me.ComboBox1.ListIndex)
    If ActiveSheet.AutoFilterMode Then
        Range("B4").AutoFilter Field:=1, Criteria1:=iArt
    End If
    Application.ScreenUpdating = True
End Sub

Private Sub CommandButton2_Click()
Application.ScreenUpdating = False
    Sheets("Переобразование в Чек Лист").Select
    Range("A2:G2").Select
    Range(Selection, Selection.End(xlDown)).Select
    Selection.Copy
    Sheets("Накопительный").Select
    Range("B" & Range("B5").End(xlDown).Row + 1).Select
    ActiveSheet.Paste
    Sheets("Накопительный").Select
    Range("B" & Range("B5").End(xlDown).Row + 1).Select
 Application.ScreenUpdating = True
 Me.Hide
End Sub

Private Sub TextBox1_Change()
Application.ScreenUpdating = False
Sheets("Переобразование в Чек Лист").Select
Range("G2:G200") = Me.TextBox1.Text

Private Sub ComboBox1_Change()
 Dim iSotrud As String
    On Error Resume Next
    iSotrud = Me.ComboBox1.List(Me.ComboBox1.ListIndex)
    If ActiveSheet.AutoFilterMode Then
        Range("B4").AutoFilter Field:=1, Criteria1:=iSotrud & "*"
    End If
End Sub

Private Sub ComboBox2_Change()
 Dim iSotrud As String
    On Error Resume Next
    iSotrud = Me.ComboBox1.List(Me.ComboBox1.ListIndex)
    If ActiveSheet.AutoFilterMode Then
        Range("H4").AutoFilter Field:=7, Criteria1:=iSotrud & "*"
    End If
End Sub
Private Sub Worksheet_Change(ByVal Target As Range)
If Target.Cells.Count > 1 Then Exit Sub
 If Intersect(Range("B4:B"), Target) Is Nothing Then Exit Sub
   ComboBox1.ListFillRange = Range("B4" & Cells(Rows.Count, 1).End(xlUp).Row).Address
 End Sub