Sub СоздатьСписокБезПовторов()
    Dim vItem, avArr, i As Long, iColl As New Collection, lastRow As Long
     
    With ActiveSheet
        lastRow = .Cells(.Rows.Count, 4).End(xlUp).Row
        ReDim avArr(1 To lastRow, 1 To 1)
        On Error Resume Next
        For Each vItem In .Range("D2:D" & lastRow).Value
            If Not IsEmpty(vItem) Then
                iColl.Add vItem, CStr(vItem)
                If Err = 0 Then
                    i = i + 1
                    avArr(i, 1) = vItem
                Else
                    Err.Clear
                End If
            End If
        Next
     .Range("D2:D" & lastRow).Value = Empty    ' очистить эти ячейки
    End With
    On Error GoTo 0
    
    If i Then Sheets("Продукты").[D2].Resize(i).Value = avArr
End Sub

Sub Макрос1()
    With ActiveWorkbook.ActiveSheet
        .Sort.SortFields.Clear
        .Sort.SortFields.Add Key:=.UsedRange.Range("D4").Resize(.UsedRange.Rows.Count - 1), SortOn:=xlSortOnValues, Order:=xlAscending, DataOption:=xlSortNormal
        .Sort.SetRange .UsedRange
        .Sort.Header = xlYes
        .Sort.MatchCase = False
        .Sort.Orientation = xlTopToBottom
        .Sort.SortMethod = xlPinYin
        .Sort.Apply
    End With
End Sub

Sub Vstavit_formulu1()
    Application.ScreenUpdating = False
    ActiveCell.Offset(0, 2).Range("A1").Select
    ActiveCell.FormulaR1C1 = "=VLOOKUP(RC[-2],CHOOSE({1,2},'Средства измерений'!C6,'Средства измерений'!C2),2,0)"
    ActiveCell.Offset(0, 1).Range("A1").Select
    ActiveCell.FormulaR1C1 = "=VLOOKUP(RC[-3],CHOOSE({1,2},'Средства измерений'!C6,'Средства измерений'!C3),2,0)"
    ActiveCell.Offset(0, 1).Range("A1").Select
    ActiveCell.FormulaR1C1 = "=VLOOKUP(RC[-4],CHOOSE({1,2},'Средства измерений'!C6,'Средства измерений'!C4),2,0)"
    ActiveCell.Offset(0, 1).Range("A1").Select
    ActiveCell.FormulaR1C1 = "=VLOOKUP(RC[-5],CHOOSE({1,2},'Средства измерений'!C6,'Средства измерений'!C5),2,0)"
    ActiveCell.Offset(0, -3).Range("A1:D1").Select
    Selection.Copy
    Selection.PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks:=False, Transpose:=False
    ActiveSheet.Paste
    Application.CutCopyMode = False
    ActiveCell.Offset(1, -2).Range("A1").Select
    Application.ScreenUpdating = True
End Sub

Sub macro()
    Dim i As Integer, j As Integer, index As Integer
    i = 0
    j = 0
    index = 1
    
    While Worksheets("Месяцы").Cells(1 + i, 1) <> 0
        For j = 1 To Sheets.Count Step 1
            If Sheets(j).Name <> Worksheets("Месяцы").Cells(1 + i, 1) Then
                index = index + 1
            ElseIf Sheets(j).Name = Worksheets("Месяцы").Cells(1 + i, 1) Then
                j = Sheets.Count
            End If
        Next j
        'MsgBox index
        'MsgBox Sheets.Count + 1
        If index = Sheets.Count + 1 Then
            Sheets.Add After:=Sheets(Sheets.Count)
            ActiveSheet.Name = Worksheets("Месяцы").Cells(1 + i, 1)
        End If
        index = 1
        i = i + 1
    Wend
    Worksheets("Месяцы").Activate
End Sub

Private Sub Worksheet_SelectionChange(ByVal Target As Range)
  If Target.Count > 1 Then Exit Sub
   If Not Intersect(Target, [B34,B35,B36,B37,B38,B39,B40,B41,B42,B43,B44,B45,B46,B47,B48]) Is Nothing Then
   Поиск_приборов_одна.Show
   End If
End Sub

Sub Копировать_данные()
    Application.ScreenUpdating = False
    Sheets("Лист1").Range("A21:J250").Copy
    Sheets("Лист3").Range("A3").PasteSpecial xlPasteValues
    Application.ScreenUpdating = True
End Sub

 For Each vItem In Range("A2", Cells(Rows.Count, 1).End(xlUp)).Value

Sub Extract_Unique()
    Dim vItem, avArr, li As Long
    ReDim avArr(1 To Rows.Count, 1 To 1)
    With New Collection
        On Error Resume Next
        For Each vItem In Range("A2", Cells(Rows.Count, 1).End(xlUp)).Value
            'Cells(Rows.Count, 1).End(xlUp) – определяет последнюю заполненную ячейку в столбце А
            .Add vItem, CStr(vItem)
            If Err = 0 Then
                li = li + 1: avArr(li, 1) = vItem
            Else: Err.Clear
            End If
        Next
    End With
    If li Then Sheets("Лист2").[E2].Resize(li).Value = avArr
End Sub

Private Sub
Worksheet_BeforeDoubleClick(ByVal Target As Range, Cancel As Boolean)
If Not
Intersect(Target, Range("C:C")) Is Nothing And Target.Columns.Count =
1 Then
        Call Userform1
            Userform1
                .TextBox2 = ActiveCell.Offset(0, 0) 'Наименование
                .TextBox1 = ActiveCell.Offset(0, -1) '№ п/п
                .TextBox3 = ActiveCell.Offset(0, 3) 'Положение                
            End With
        End If
End Sub

If Intersect(ActiveCell, Range("A:A")) Is Nothing Then
        MsgBox "Выделите нужную ячейку в столбце A", vbInformation, "Внимание!!!"
        Exit Sub
    End If

Sub SplitSheets4()
    Dim CurW As Window
    Dim TempW As Window
    Set CurW = ActiveWindow
    Set TempW = ActiveWorkbook.NewWindow
    CurW.SelectedSheets.Copy
    TempW.Close
End Sub

Sub AAA()
Cells.Select
    With Selection.Validation
        .Delete
        .Add Type:=xlValidateInputOnly, AlertStyle:=xlValidAlertStop, Operator _
        :=xlBetween
        .IgnoreBlank = True
        .InCellDropdown = True
        .InputTitle = ""
        .ErrorTitle = ""
        .InputMessage = ""
        .ErrorMessage = ""
        .ShowInput = True
        .ShowError = True
    End With
    Range("F12").Select
        Cells.Select
    Selection.Copy
    Selection.PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks _
        :=False, Transpose:=False
    Range("A1").Select
    Application.CutCopyMode = False
    ActiveCell.FormulaR1C1 = ""
    Range("A1").Select
    Cells.FormatConditions.Delete
  End Sub