=СУММПРОИЗВ((A2:K2>0)*(B2:L2)*(ОСТАТ(СТОЛБЕЦ(B2:L2);2)=0))

Sub Условное_форматирование_ячеек()
    Dim rr As Range

    Set rr = Определить_ячейки 'Запускаем макрос
    If rr Is Nothing Then
        Exit Sub
    End If
    With rr
        .FormatConditions.Add Type:=xlTextString, String:="Фрукт", TextOperator:=xlContains
        .FormatConditions(.FormatConditions.Count).SetFirstPriority
        With .FormatConditions(1).Borders(xlLeft)
            .LineStyle = xlContinuous
            .TintAndShade = 0
            .Weight = xlThin
        End With
        With .FormatConditions(1).Borders(xlRight)
            .LineStyle = xlContinuous
            .TintAndShade = 0
            .Weight = xlThin
        End With
        With .FormatConditions(1).Borders(xlTop)
            .LineStyle = xlContinuous
            .TintAndShade = 0
            .Weight = xlThin
        End With
        With .FormatConditions(1).Borders(xlBottom)
            .LineStyle = xlContinuous
            .TintAndShade = 0
            .Weight = xlThin
        End With
        With .FormatConditions(1).Interior
            .PatternColorIndex = xlAutomatic
            .Color = 5296274
            .TintAndShade = 0
        End With
        .FormatConditions(1).StopIfTrue = False
        
        .FormatConditions.Add Type:=xlTextString, String:="Яблоко", _
            TextOperator:=xlContains
        .FormatConditions(.FormatConditions.Count).SetFirstPriority
        With .FormatConditions(1).Borders(xlLeft)
            .LineStyle = xlContinuous
            .TintAndShade = 0
            .Weight = xlThin
        End With
        With .FormatConditions(1).Borders(xlRight)
            .LineStyle = xlContinuous
            .TintAndShade = 0
            .Weight = xlThin
        End With
        With .FormatConditions(1).Borders(xlTop)
            .LineStyle = xlContinuous
            .TintAndShade = 0
            .Weight = xlThin
        End With
        With .FormatConditions(1).Borders(xlBottom)
            .LineStyle = xlContinuous
            .TintAndShade = 0
            .Weight = xlThin
        End With
        With .FormatConditions(1).Interior
            .PatternColorIndex = xlAutomatic
            .Color = 15773696
            .TintAndShade = 0
        End With
        .FormatConditions(1).StopIfTrue = False
    End With
End Sub

Function Определить_ячейки()
    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
        Set Определить_ячейки = iRng
      End If
    End With
End Function

sFolder = Range("A4").Value

.Attachments.Add sFolder & sFiles

=СМЕЩ(Лист1!$C$4:$C$4;;;СЧЁТ(Лист1!$C$4:$C$8);)

Private Sub Worksheet_Change(ByVal Target As Range)
Unprotect "подбор"
'Updated by Extendoffice 20180830
Dim xCellColumn As Integer
Dim xTimeColumn As Integer
Dim xRow, xCol As Integer
Dim xDPRg, xRg As Range
xCellColumn = 10
xTimeColumn = 13
xRow = Target.Row
xCol = Target.Column
If Target.Text <> "" Then
   Application.EnableEvents = 0 'отключаем отслеживание событий
   If xCol = xCellColumn Then
      Cells(xRow, xTimeColumn) = Now()
   Else
       On Error Resume Next
       Set xDPRg = Target.Dependents
       For Each xRg In xDPRg
           If xRg.Column = xCellColumn Then
               Cells(xRg.Row, xTimeColumn) = Now()
           End If
       Next
                 End If
    Application.EnableEvents = 1 'обязательно возвращаем отслеживание событий
End If
Protect Password:="подбор", Scenarios:=True, UserInterfaceOnly:=True
End Sub

= ('Кол-во записей всего'-'Кол-во ОЗ' )/'Входящие звонки'

=СЧЕТЕСЛИ(А1:M300;"*~*~*~**")

Sub sa123()
' Recorded 22.08.2025
Dim Wb As Object, ExApp As Object, Cell As Object
Set Wb = GetObject("C:\Users\user\Desktop\123.xlsx")
Set ExApp = Wb.Application
Dim Paste1 As ShapeRange
Dim row&
Dim col&: col = 2
For row = 1 To 10
   Set Cell = ExApp.ActiveSheet.Cells(row,col)
   Cell.Copy
   ActiveLayer.PasteSpecial "Rich Text Format"
   Set Paste1 = ActiveSelectionRange
   Paste1.ConvertToCurves
Next
End Sub

Private Sub Worksheet_Change(ByVal Target As Range)
    Dim rr As Range, rc As Range
    Set rr = Intersect(Target, Range("B1:B50"))
    If Not rr Is Nothing Then
        For Each rc In rr
            If rr.Value <> "" Then
                If rc.Offset(, -1).Value <> "" Then
                    rc.Offset(, -1).ClearContents
                End If
                rc.Offset(, -1).CellControl.SetCheckbox
            Else
                rc.Offset(, -1).ClearContents RemoveControls:=True
            End If
        Next
    End If
End Sub