Selection.FormatConditions.Add Type:=xlTextString, String:="Фрукт",  TextOperator:=xlContains
Selection.FormatConditions(Selection.FormatConditions.Count).SetFirstPriority

With Sheets("Лист2").Range("C7").Borders(xlLeft)
        .LineStyle = xlContinuous
        .TintAndShade = 0
        .Weight = xlThin
End With
With Sheets("Лист2").Range("C7").Borders(xlRight)
        .LineStyle = xlContinuous
        .TintAndShade = 0
        .Weight = xlThin
End With
With Sheets("Лист2").Range("C7").Borders(xlTop)
        .LineStyle = xlContinuous
        .TintAndShade = 0
        .Weight = xlThin
End With
With Sheets("Лист3").Range("C7").Borders(xlBottom)
        .LineStyle = xlContinuous
        .TintAndShade = 0
        .Weight = xlThin
End With
With Sheets("Лист2").Range("C7").Interior
        .PatternColorIndex = xlAutomatic
        .Color = 5296274
        .TintAndShade = 0
End With

Sub Выделить_ячейки()
Dim lRow&
Dim iCl As Range
Dim iRng As Range
On Error Resume Next
With Sheets("Лист2")
  lRow = .Cells(.Rows.Count, "D").End(xlUp).Row
  lRow = IIf(lRow < 3, 3, lRow)
  For Each iCl In .Range("D3:N" & lRow).Cells
    If Not IsEmpty(iCl) Then
      If Not iRng Is Nothing Then
        Set iRng = Union(iRng, iCl.Offset(, 0))
      Else
        Set iRng = iCl.Offset(, 0)
      End If
    End If
  Next
  If Not iRng Is Nothing Then iRng.Select
End With
End Sub

Unload Средства_измерений
VBAProject.Средства_измерений.Show (0)

Unload Средства_измерений
VBAProject.A00_Заказчик.Show (0)

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

    Cells(iLR_A, H).Resize(iLastRow).Value = Range(Cells(3, j), Cells(iLastRow, j)).Value

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
         Range("A1:H3").MergeCells = False
        .Sort.Apply
         Range("A1:H3").Merge (True)
    End With
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