If lRow >= 1 And lRow <= 27 Then 'если номер строки для переноса данных между 18 и 27 то вставляем данные

Private Sub ListBox1_DblClick(ByVal Cancel As MSForms.ReturnBoolean)

Range("D18") = ListBox1.List(ListBox1.ListIndex, 2)
Range("H18") = ListBox1.List(ListBox1.ListIndex, 3)
Range("Z18") = ListBox1.List(ListBox1.ListIndex, 8)
 
    

End Sub

Private Sub Worksheet_Change(ByVal Target As Range)
    If Not Intersect(Target, Columns(1)) Is Nothing Then
        Application.EnableEvents = False
Dim iRow As Long
Dim FoundCell As Range
Dim FAdr As String
 With Worksheets("1")
    Set FoundCell = .Columns(1).Find(Target, , xlValues, xlWhole)
     If Not FoundCell Is Nothing Then
      FAdr = FoundCell.Address
      iRow = Target.Row
      Do
        Cells(iRow, 2) = .Cells(FoundCell.Row, 2)
        Set FoundCell = .Columns(1).FindNext(FoundCell)
        iRow = iRow + 1
        If FoundCell.Address <> FAdr Then Cells(iRow, 1) = Target
      Loop While FoundCell.Address <> FAdr
     End If
 End With
    End If
    Application.EnableEvents = True
End Sub

If Not Intersect(Target, Range("E3:E100")) Is Nothing Then

Private Sub Worksheet_Change(ByVal Target As Range)
    Dim w As Object
    On Error Resume Next
    If Range("E3").Value = 1 Then
    
    Call sndPlaySound("C:\Windows\Media\tada.wav", 1)
       End If
End Sub

Private Sub Workbook_Open()
 Sheets("Лист1").Select
ActiveSheet.Unprotect Password:="321"
    Range("B8:AH8").Locked = True
    ActiveSheet.Protect Password:="321"
End Sub

Private Sub Workbook_Open()
   Cells.Locked = False '
    Range("F5:AH5").Locked = True
    ActiveSheet.Protect DrawingObjects:=True, Contents:=True, Scenarios:=True
End Sub

Private Sub Worksheet_Change(ByVal Target As Range)
Do While Range("B3").Offset(LineCt, 0) = UCase(LineOfText)
'Call Clean
Exit Sub
Loop
Sheets("Лист2").Select
ActiveSheet.Range("$A$5:$G$31").AutoFilter Field:=7, Criteria1:=Worksheets("Лист1").Range("B3").Value
End Sub

'Страница 1
Worksheets("1").Range("A1:A60").Copy
Worksheets("2").Range("D4").PasteSpecial Paste:=xlPasteValues
Worksheets("1").Range("B1:B60").Copy
Worksheets("2").Range("C4").PasteSpecial Paste:=xlPasteValues
Worksheets("1").Range("C1:C60").Copy
Worksheets("2").Range("G4").PasteSpecial Paste:=xlPasteValues
Worksheets("1").Range("D1:D60").Copy
Worksheets("2").Range("L4").PasteSpecial Paste:=xlPasteValues
Worksheets("1").Range("E1:E60").Copy
Worksheets("2").Range("J4").PasteSpecial Paste:=xlPasteValues
Application.CutCopyMode = False
Sheets("1").Select 'удаляем 60 строк
    Rows("1:60").Select
    Selection.Delete Shift:=xlUp
Do While Range("B1").Offset(LineCt, 0) = UCase(LineOfText)

Call SHel
Exit Sub
Loop

'Страница 2
Worksheets("1").Range("A1:A60").Copy
Worksheets("2").Range("D75").PasteSpecial Paste:=xlPasteValues
Worksheets("1").Range("B1:B60").Copy
Worksheets("2").Range("C75").PasteSpecial Paste:=xlPasteValues
Worksheets("1").Range("C1:C60").Copy
Worksheets("2").Range("G75").PasteSpecial Paste:=xlPasteValues
Worksheets("1").Range("D1:D60").Copy
Worksheets("2").Range("L75").PasteSpecial Paste:=xlPasteValues
Worksheets("1").Range("E1:E60").Copy
Worksheets("2").Range("J75").PasteSpecial Paste:=xlPasteValues
Application.CutCopyMode = False
Sheets("1").Select 'удаляем 60 строк
    Rows("1:60").Select
    Selection.Delete Shift:=xlUp
Do While Range("B1").Offset(LineCt, 0) = UCase(LineOfText)
Call SHel
Exit Sub
Loop

Call Выход

Sub CreateMenu()
 Dim HelpMenu As CommandBarControl
    Dim NewMenu As CommandBarPopup
    Dim MenuItem As CommandBarControl
    Dim Submenuitem As CommandBarButton
'   Удаление меню, если таковое существует
    Call DeleteMenu
'   Поиск меню Справка
    Set HelpMenu = CommandBars(1).FindControl(ID:=30010)
    If HelpMenu Is Nothing Then
'       Добавление меню в конец строки меню
        Set NewMenu = CommandBars(1).Controls.Add _
          (Type:=msoControlPopup, _
           temporary:=True)
    Else
'      Добавление меню перед меню Help
        Set NewMenu = CommandBars(1).Controls.Add _
          (Type:=msoControlPopup, _
           Before:=HelpMenu.Index, _
           temporary:=True)
    End If
'   Добавление подписи
    NewMenu.Caption = "&Моё меню"
'   Первый элемент меню
    Set MenuItem = NewMenu.Controls.Add _
      (Type:=msoControlButton)
    With MenuItem
        .Caption = "&Поиск данных"
        .FaceId = 173
        .OnAction = "Poisk"
    End With
End Sub