Private Sub Worksheet_BeforeRightClick(ByVal Target As Range, Cancel As Boolean)
   Cancel = True
   Dim b As CommandBar
   dx = 0: dy = 0
   For Each b In Application.CommandBars
     If b.Visible Then
       Select Case b.Position
        Case msoBarLeft: dx = dx + b.Width
        Case msoBarMenuBar, msoBarTop: dy = dy + b.Height
       End Select
     End If
   Next
   With Target.Application.ActiveWindow
     UserForm1.Left = (Target.Left - .VisibleRange.Left) * .Zoom / 100 + .Application.Left + dx
     UserForm1.Top = (Target.Top - .VisibleRange.Top) * .Zoom / 100 + .Application.Top + dy
     UserForm1.Show
   End With
 End Sub  

With ActiveCell.Characters(Start:=47, Length:=31).Font 

 Sub Дополнения_текст()
If Not Application.Intersect(ActiveCell, Range("G2:G1000")) Is Nothing Then
If ActiveCell.Value = "" Then
Exit Sub
End If
If ActiveCell.Value <> "" Then
ActiveCell.Value = ActiveCell.Value & " РЕЗУЛЬТАТ ЗВОНКА И ДОПОЛНЕНИЯ:"
ActiveCell.Select
    
    With ActiveCell.Characters(Start:=47, Length:=31).Font
        .Name = "Calibri"
        .FontStyle = "полужирный"
        .Size = 11
        .Strikethrough = False
        .Superscript = False
        .Subscript = False
        .OutlineFont = False
        .Shadow = False
        .Underline = xlUnderlineStyleNone
        .Color = -4165632
        .TintAndShade = 0
        .ThemeFont = xlThemeFontMinor
    End With
    ActiveCell.Offset(0, 1).Activate
End If
End If
End Sub

Range("G3").Select
    ActiveCell.FormulaR1C1 = _
        "Здравствуйте - хотела заказать у вас пылесос   РЕЗУЛЬТАТ ЗВОНКА И ДОПОЛНЕНИЯ:"
    With ActiveCell.Characters(Start:=1, Length:=46).Font
        .Name = "Calibri"
        .FontStyle = "обычный"
        .Size = 11
        .Strikethrough = False
        .Superscript = False
        .Subscript = False
        .OutlineFont = False
        .Shadow = False
        .Underline = xlUnderlineStyleNone
        .ThemeColor = xlThemeColorLight1
        .TintAndShade = 0
        .ThemeFont = xlThemeFontMinor
    End With
    With ActiveCell.Characters(Start:=47, Length:=31).Font
        .Name = "Calibri"
        .FontStyle = "полужирный"
        .Size = 11
        .Strikethrough = False
        .Superscript = False
        .Subscript = False
        .OutlineFont = False
        .Shadow = False
        .Underline = xlUnderlineStyleNone
        .Color = -4165632
        .TintAndShade = 0
        .ThemeFont = xlThemeFontMinor
    End With
End Sub
 

Sub Дополнения_текст()
If Not Application.Intersect(ActiveCell, Range("G2:G1000")) Is Nothing Then
If ActiveCell.Value = "" Then
Exit Sub
End If
If ActiveCell.Value <> "" Then
ActiveCell.Value = "РЕЗУЛЬТАТ ЗВОНКА И ДОПОЛНЕНИЯ:"
End If
End If
End Sub

Private Sub Workbook_Open() 
 
    'если время с 8.30 до 9.00 то 
    If Time > TimeValue("08:30:00") And Time < TimeValue("09:00:00") Then 
        Application.Quit 'закрываем приложение 
        ThisWorkbook.Close False 'закрываем книгу без сохранения 
    End If 
 

Sub Создать_папки1() 
    On Error Resume Next 
 
    ' название папки, 
    Const folder$ = "Сотрудники" 
 
    ' создаём папку для файла, если её ещё нет 
    MkDir ThisWorkbook.Path & "\" & folder$ 
     
    ' создаём папку АРХИВ вложена в папку Сотрудники
    MkDir ThisWorkbook.Path & "\" & folder$ & "\" & "Архив" 
 
    ' создаем подпапки для каждого листа 
    For Each sh In ThisWorkbook.Worksheets 
    If sh.Name <> "Расписание" And sh.Name <> "Норма" And sh.Name <> "Общий" Then 'выбираем только листы сотрудников- остальные исключаем 
       MkDir ThisWorkbook.Path & "\" & folder$ & "\" & sh.Name 
    End If 
    Next sh  
End Sub  

 Sub Создать_папки() 
    On Error Resume Next 
 
    ' название папки, 
    Const folder$ = "Сотрудники" 
 
    ' создаём папку для файла, если её ещё нет 
    MkDir ThisWorkbook.Path & "\" & folder$ 
     
    ' создаём папку АРХИВ 
    MkDir ThisWorkbook.Path & "\" & "Архив" 
 
    ' создаем подпапки для каждого листа 
    For Each sh In ThisWorkbook.Worksheets 
    If sh.Name <> "Расписание" And sh.Name <> "Норма" And sh.Name <> "Общий" Then 'выбираем только листы сотрудников- остальные исключаем 
       MkDir ThisWorkbook.Path & "\" & folder$ & "\" & sh.Name 
    End If 
    Next sh    
 End Sub 

For Each i In ThisWorkbook.Sheets 
    If i.Name <> "План занятости" And i.Name <> "Исходные данные" Then 
     i.Columns(7).ColumnWidth = 118 
    End If 
Next 

Private Sub Workbook_Open()
Dim z
For z = 1 To Sheets.Count
If Sheets(z).Name = "План занятости" And Sheets(z).Name = "Исходные данные" Then Exit Sub 
z.Columns(7).ColumnWidth = 118 'устанавливаем требуемую ширину столбца G кроме листов "Исходные данные" и "План занятости"
Next
End Sub

Private Sub Workbook_Open()
Dim wsSh As Worksheet
For Each wsSh In Sheets
Application.ScreenUpdating = False
If wsSh.Rows("6:5000", 7).WrapText = False Then
     wsSh.Rows("6:5000", 7).WrapText = True
End If
Next wsSh
Application.ScreenUpdating = True
End Sub

Private Sub CommandButton1_Click()
        Worksheets("Общая база").Range("$B$5").AutoFilter _
        field:=2, _
        Criteria1:=ComboBox1.Text
        
        Worksheets("Общая база").Range("$C$5").AutoFilter _
        field:=3, _
        Criteria1:=ComboBox2.Text
        
    End Sub