Private Sub UserForm_Initialize()
'(отбор уникальных значений)
Dim AllCells As Range, rCell As Range
Dim NoDupes As New Collection
Dim Item
     
    With Worksheets("справка")
    'Элементы находятся в столбце A
        Set AllCells = .Range("AA2:AA" & .Cells(Rows.Count, 27).End(xlUp).Row)
    End With
    'заполняем коллекцию элементами без повторений
    On Error Resume Next
    For Each rCell In AllCells
        NoDupes.Add rCell.Value, CStr(rCell.Value)
    Next rCell
    On Error GoTo 0
 
    'Добавление уникальных значений в  ComboBox
    For Each Item In NoDupes
        Me.ComboBox1.AddItem Item
    Next Item
End Sub
 
 
Private Sub ComboBox1_Change()
Dim i As Long, LastRow As Long, kategorija As String
    kategorija = Me.ComboBox1
    With Sheets("справка")
        LastRow = .Cells(Rows.Count, 27).End(xlUp).Row
        For i = 2 To LastRow
            If .Cells(i, 27) = kategorija Then
            End If
        Next
    End With
End Sub

Private Sub TextBox1_Change()
If TextBox1 = "" Then Exit Sub
T = TextBox1
If Len(TextBox1) > 1 Then: If T > 75.9 Or T < 25.9 Then TextBox1 = "": MsgBox "неверный ввод" & vbNewLine & "Значения от 26,1 до 75,9, " & vbNewLine & "" & vbNewLine & "Пример    42,1", vbOKOnly + vbExclamation, ""
End Sub

Private Sub Worksheet_Change(ByVal Target As Range)
If Target.Cells.Count > 1 Then Exit Sub
If Not Intersect(Target, Range("E3:E26")) Is Nothing Then
    x = Target.Row
    Range(Cells(x, 10), Cells(x, 31)).Copy Destination:=Cells(x, 11)
    Cells(x, 10) = Target
End If
End Sub 

Sub Macros5()
Sheets("Лист1").Select
Set fcell = Columns("A:A").Find("Санкт-Петербург")
If Not fcell Is Nothing Then
    MsgBox "Санкт-Петербург Нашел в строке: " + CStr(fcell.Row)
Set fcell = Columns("A:A").Find("Москва")
If Not fcell Is Nothing Then
    MsgBox "Москва Нашел в строке: " + CStr(fcell.Row)
End If
End If
End Sub

Private Sub Worksheet_Change(ByVal Target As Range)
    If Not Intersect(Target, Range("A2:J2")) Is Nothing Then
    UserForm1.Show 0
    UserForm1.Repaint
        On Error Resume Next
        ActiveSheet.ShowAllData
        Range("A1").CurrentRegion.AdvancedFilter Action:=xlFilterInPlace, CriteriaRange:=Range("A1:J2")
    End If
    Unload UserForm1
End Sub

Private Sub Worksheet_Change(ByVal Target As Range)
     
    For Each cell In Target   'проходим по всем измененным ячейкам
       If Not Intersect(cell, Range("A2:A100")) Is Nothing Then  'если изменененная ячейка попадает в диапазон A2:A100
            With cell.Offset(0, 1)         'вводим в соседнюю справа ячейку дату
               .Value = Now
               .EntireColumn.AutoFit  'выполняем автоподбор ширины для столбца B, чтобы дата умещалась в ячейке
            End With
       End If
    Next cell
End Sub

Private Sub Worksheet_Change(ByVal Target As Range)
Dim vRange As Range
  Set vRange = Range("A5:A100")
  Set Target = Intersect(Target, vRange)
  If Target Is Nothing Then Exit Sub
  For Each vRange In Target
    If Not IsNumeric(vRange) Then
      Application.EnableEvents = False
      Application.Undo
      Application.EnableEvents = True
      MsgBox "Ввод отменён. Недопустимое значение", vbCritical
      Exit Sub
    End If
  Next
End Sub

Private Sub Workbook_Open()
If ActiveWorkbook.Path <> "C:\Users\Badim\Desktop\Новая папка" Then
    Application.DisplayAlerts = False
    ThisWorkbook.ChangeFileAccess xlReadOnly
    Kill ThisWorkbook.FullName
    Application.DisplayAlerts = True
    ThisWorkbook.Close 0
  End If
  End Sub

If ActiveWorkbook.Path <> "C:\Users\Badim\Desktop\Новая папка" Then
If ActiveWorkbook.Path <> "Z:\Users\Badim\Desktop\Новая папка" Then
If ActiveWorkbook.Path <> "D:\Users\Badim\Desktop\Новая папка" Then

Private Sub Worksheet_Change(ByVal Target As Range)
    If Not Intersect(Target, Range("A2:I2")) Is Nothing Then
     ActiveSheet.Unprotect Password:=""
        On Error Resume Next
        ActiveSheet.ShowAllData
        Range("A7").CurrentRegion.AdvancedFilter Action:=xlFilterInPlace, CriteriaRange:=Range("A1").CurrentRegion
        ActiveSheet.Protect Password:=""
   End If
  Dim rg As Range, rw As Range, r&
  Set rg = Intersect(Target, Range("AD:AE"))
  If rg Is Nothing Then Exit Sub
  ActiveSheet.Unprotect Password:=""
  For Each rw In rg.Rows
    r = rw.Row
    If Cells(r, 30) <> "" And Cells(r, 31) <> "" And _
    InStr(Cells(r, 35), Cells(r, 30).Text) = 0 And _
    InStr(Cells(r, 35), Cells(r, 31)) = 0 Then
      Application.EnableEvents = False
      Range(Cells(r, 35), Cells(r, Columns.Count).End(xlToLeft)).Copy Cells(r, 36)
      Cells(r, 35) = Cells(r, 30).Text & " " & Cells(r, 31): Application.EnableEvents = True
    End If
  Next
  ActiveSheet.Protect Password:=""
End Sub

Sub ee()
  Application.EnableEvents = True
End Sub

Private Sub Worksheet_Change(ByVal Target As Range)
  ff = ActiveCell.Address        
    If ActiveCell.Address = "$B$6" Then
      
    Range("B5:O5").Select
    Range("O5").Activate
    Selection.Copy
    Range("C5").Select
    ActiveSheet.PasteSpecial Format:=3, Link:=1, DisplayAsIcon:=False, _
        IconFileName:=False
Else
Exit Sub
End If

Private Sub Worksheet_Change(ByVal Target As Range)
    If Not Intersect(Target, Range("A2:Q2")) Is Nothing Then
   On Error Resume Next
   ActiveSheet.Unprotect Password:="1"
        ActiveSheet.ShowAllData
        Range("A7").CurrentRegion.AdvancedFilter Action:=xlFilterInPlace, CriteriaRange:=Range("A1").CurrentRegion
   ActiveSheet.Protect Password:=""
    End If
    If Not Intersect(Target, Range("A2:Q2")) Is Nothing Then
        On Error Resume Next
        ActiveSheet.ShowAllData
        Range("A7").CurrentRegion.AdvancedFilter Action:=xlFilterInPlace, CriteriaRange:=Range("A1").CurrentRegion
    End If
End Sub