=ЕСНД(ИНДЕКС(ДВССЫЛ("Остатки"&$E$27&"!$R$1:$R$9813");ПОИСКПОЗ(;СЧЁТЕСЛИ(G$2:G2;ЕСЛИ(ДВССЫЛ("Остатки"&$E$27&"!A$1:A$9813")=D$3;ДВССЫЛ("Остатки"&$E$27&"!$R$1:$R$9813");G$2));));"")

Private Sub Worksheet_SelectionChange(ByVal Target As Range)
    With Shapes(1)
        .Left = ActiveWindow.VisibleRange.Left
        .Top = ActiveWindow.VisibleRange.Top
    End With
End Sub

=СУММЕСЛИ(Амб!O2:O$1048576;Препараты[@Препараты];Амб!P2:P$1048576)

=СУММ(СМЕЩ(C3;0;0;1;$S$1))

=СЧЁТЕСЛИ(A1:M1;"~*~*~*")

=СМЕЩ(ШАХМАТКА!$A$2;14*ЦЕЛОЕ((СТРОКА()-2)/31);0)

=СМЕЩ(ШАХМАТКА!$D$3;14*ЦЕЛОЕ((СТРОКА()-2)/31);ОСТАТ(СТРОКА()-2;31))

=ЕСЛИ(ЕПУСТО(СМЕЩ(ШАХМАТКА!$D$4;14*ЦЕЛОЕ((СТРОКА()-2)/31)+СТОЛБЕЦ()-4;ОСТАТ(СТРОКА()-2;31)));"";СМЕЩ(ШАХМАТКА!$D$4;14*ЦЕЛОЕ((СТРОКА()-2)/31)+СТОЛБЕЦ()-4;ОСТАТ(СТРОКА()-2;31)))

=ЕСЛИ(ЕПУСТО(СМЕЩ(ШАХМАТКА!$D$4;14*ЦЕЛОЕ((СТРОКА()-2)/31)+СТОЛБЕЦ()-4;ОСТАТ(СТРОКА()-2;31)));"";СМЕЩ(ШАХМАТКА!$D$4;14*ЦЕЛОЕ((СТРОКА()-2)/31)+СТОЛБЕЦ()-4;ОСТАТ(СТРОКА()-2;31)))

=ЕСЛИ(A2="";E1;A2)

=ЕСЛИ(E2=E1;"";СЧЁТЕСЛИМН(E:E;E:E))

Sub Таблица_3()
    With Selection
        .FormulaR1C1 = "=IFERROR(VLOOKUP(RC2,Лист4!C1:C4,4,0), """")"
        .Value = .Value
    End With
End Sub

=4+((ДАТА(ГОД(ТДАТА());МЕСЯЦ(ТДАТА());28)-ДЕНЬНЕД(ДАТА(ГОД(ТДАТА());МЕСЯЦ(ТДАТА());28)+2;2)+7)<=КОНМЕСЯЦА(ТДАТА();0))

=МИН(B1;ВПР(ПОДСТАВИТЬ(A1;"белая";"серая");A:B;2;0);ВПР(ПОДСТАВИТЬ(A1;"белая";"черная");A:B;2;0);ВПР(ПОДСТАВИТЬ(A1;"серая";"белая");A:B;2;0);ВПР(ПОДСТАВИТЬ(A1;"серая";"черная");A:B;2;0);ВПР(ПОДСТАВИТЬ(A1;"черная";"белая");A:B;2;0);ВПР(ПОДСТАВИТЬ(A1;"черная";"серая");A:B;2;0))

=B1-C1

=ДВССЫЛ(ПОДСТАВИТЬ(ЯЧЕЙКА("адрес";F7);"$";""))+ДВССЫЛ(ПОДСТАВИТЬ(ЯЧЕЙКА("адрес";F10);"$";""))

=СУММ(ДВССЫЛ(ПОДСТАВИТЬ(ЯЧЕЙКА("адрес";F7);"$";""));ДВССЫЛ(ПОДСТАВИТЬ(ЯЧЕЙКА("адрес";F10);"$";"")))

Option Explicit

Sub ФорматВПР()
    Dim sh As Worksheet, rf As Range, cf As Range, cm As Comment
    For Each sh In ActiveWorkbook.Worksheets
        For Each cf In sh.UsedRange.Cells
            If Not cf.Comment Is Nothing Then
                On Error Resume Next
                cf.Formula = cf.Comment.Text
                If Err = 0 Then cf.ClearComments
                On Error GoTo 0
            End If
        Next
        
        On Error Resume Next
        Set rf = sh.UsedRange.SpecialCells(xlCellTypeFormulas)
        On Error GoTo 0
        If Not rf Is Nothing Then
            For Each cf In rf.Cells
                EditCell cf
            Next
        
            Set rf = Nothing
        End If
    Next
End Sub

Private Sub EditCell(rTarget As Range)
    Dim rSource As Range
    Set rSource = GetSourceCell(rTarget)
    If rSource Is Nothing Then Exit Sub
    
    Dim ss As String
    ss = rTarget.Formula
    rTarget.Value = rTarget.Value
    Dim ii As Long, ft As Font, fs As Font
    For ii = 1 To Len(rTarget.Value)
        Set ft = rTarget.Characters(Start:=ii, Length:=1).Font
        Set fs = rSource.Characters(Start:=ii, Length:=1).Font
        
        ft.Superscript = fs.Superscript
        ft.Subscript = fs.Subscript
    Next
    rTarget.AddComment
    rTarget.Comment.Text Text:=ss
    
End Sub

Private Function GetSourceCell(cl As Range) As Range
    Dim sf As String, ii As Long
    sf = cl.Formula
    ii = InStr(sf, "VLOOKUP(")
    If ii = 0 Then Exit Function
    sf = Mid(sf, ii + Len("VLOOKUP("), Len(sf))
    
    ii = InStrRev(sf, ")")
    If ii = 0 Then Exit Function
    sf = Mid(sf, 1, ii - 1)
    
    Dim arr As Variant
    arr = Split(sf, ",")
    
    Dim r1 As Range, r2 As Range
    On Error Resume Next
    Set r1 = cl.Parent.Range(arr(0))
    Set r2 = Range(arr(1))
    
    Set GetSourceCell = r2.Cells(WorksheetFunction.Match(r1.Value, r2.Columns(1), CLng(arr(3))), CLng(arr(2)))
    On Error GoTo 0
End Function

=СУММ(ДВССЫЛ(ПОДСТАВИТЬ(ЯЧЕЙКА("адрес";F7)&":"&ЯЧЕЙКА("адрес";F10);"$";"")))

=СУММ(ДВССЫЛ(СЦЕПИТЬ("F7";":";"F10")))

Option Explicit

Sub Разобрать()
    CloseEmptyWb
    Dim shSource As Worksheet
    Set shSource = ActiveSheet
    
    shSource.Copy
    Dim shTarget As Worksheet
    Set shTarget = ActiveSheet
    
    Dim Application_Calculation As XlCalculation: Application_Calculation = Application.Calculation: Application.Calculation = xlCalculationManual
    
    TargetSheetJob shTarget
    
    Application.Calculation = Application_Calculation
    shTarget.Parent.Saved = True
End Sub
 
Private Sub TargetSheetJob(shTarget As Worksheet)
    With shTarget
        SplitHeader .Range("B2")
        
        Dim yt As Long, y0 As Long, y3 As Long
        For yt = 4 To .UsedRange.Row + .UsedRange.Rows.Count - 1
            If .Cells(yt, 3).IndentLevel = 0 Then
                y0 = yt
            ElseIf .Cells(yt, 3).IndentLevel = 3 Then
                y3 = yt
            ElseIf .Cells(yt, 3).IndentLevel = 5 Then
                .Cells(yt, 2).Cut Destination:=.Cells(yt, 4)
                .Cells(y0, 2).Copy .Cells(yt, 2)
                .Cells(y3, 2).Copy .Cells(yt, 3)
            End If
        Next
        
        For yt = .UsedRange.Row + .UsedRange.Rows.Count - 1 To 4 Step -1
            If IsEmpty(.Cells(yt, 4)) Then
                .Rows(yt).Delete
            End If
        Next
        
        yt = .UsedRange.Row + .UsedRange.Rows.Count - 1
        
        With .Range("E4:V4").Rows(0)
            .FormulaR1C1 = "=SUM(R[1]C:R" & yt & "C)"
            .Formula = Application.ConvertFormula(.Formula, xlA1, xlA1, xlRelative)
        End With
        
        Dim xs As Long, rs As Range
        xs = .UsedRange.Column + .UsedRange.Columns.Count + 1
        Set rs = .Range(.Cells(4, xs), .Cells(yt, xs))
        Set rs = rs.Resize(, 3)
        rs.Columns(1).Formula = "=MATCH(B:B,B:B,0)"
        rs.Columns(2).FormulaR1C1 = rs.Columns(1).FormulaR1C1
        rs.Columns(3).FormulaR1C1 = rs.Columns(1).FormulaR1C1
        
        With .Sort
            .SortFields.Clear
            .SortFields.Add Key:=rs.Columns(2), SortOn:=xlSortOnValues, Order:=xlDescending, DataOption:=xlSortNormal
            .SortFields.Add Key:=rs.Columns(3), SortOn:=xlSortOnValues, Order:=xlAscending, DataOption:=xlSortNormal
            .SortFields.Add Key:=rs.Columns(1), SortOn:=xlSortOnValues, Order:=xlAscending, DataOption:=xlSortNormal
            .SetRange shTarget.Range(shTarget.Cells(4, 2), shTarget.Cells(yt, xs + 2))
            .Header = xlNo
            .MatchCase = False
            .Orientation = xlTopToBottom
            .SortMethod = xlPinYin
            .Apply
        End With
        rs.Clear
    End With
End Sub

Private Sub SplitHeader(cl As Range)
    Dim arr As Variant
    arr = Split(cl.Value, "/")
    cl.Cells(1, 2).EntireColumn.Resize(, UBound(arr)).Insert
    cl.Resize(1, UBound(arr) + 1).Value = arr
End Sub

Private Sub CloseEmptyWb()
    Dim wb As Workbook
    For Each wb In Application.Workbooks
        If wb.Path = "" Then wb.Close False
    Next
End Sub

=ЕСЛИ(H25="да";$D$6/СЧЁТЕСЛИ($H$25:$H$55;"да")-1*(ЕСЛИ(H25="да";$D$6/СЧЁТЕСЛИ($H$25:$H$55;"да");0)+ЕСЛИ(J25="да";$D$13/СЧЁТЕСЛИ($J$25:$J$55;"да");0)+ЕСЛИ(L25="да";$D$14/СЧЁТЕСЛИ($L$25:$L$55;"да");0)+ЕСЛИ(N25="да";$D$15/СЧЁТЕСЛИ($N$25:$N$55;"да");0)+ЕСЛИ(P25="да";$D$16/СЧЁТЕСЛИ($P$25:$P$55;"да");0)-$D$17/ДЕНЬ(КОНМЕСЯЦА($B$1;0)))/(($H25="да")+($J25="да")+($L25="да")+($N25="да")+($P25="да"));0)

=ЕСЛИ(J25="да";$D$13/СЧЁТЕСЛИ($J$25:$J$55;"да")-1*(ЕСЛИ(H25="да";$D$6/СЧЁТЕСЛИ($H$25:$H$55;"да");0)+ЕСЛИ(J25="да";$D$13/СЧЁТЕСЛИ($J$25:$J$55;"да");0)+ЕСЛИ(L25="да";$D$14/СЧЁТЕСЛИ($L$25:$L$55;"да");0)+ЕСЛИ(N25="да";$D$15/СЧЁТЕСЛИ($N$25:$N$55;"да");0)+ЕСЛИ(P25="да";$D$16/СЧЁТЕСЛИ($P$25:$P$55;"да");0)-$D$17/ДЕНЬ(КОНМЕСЯЦА($B$1;0)))/(($H25="да")+($J25="да")+($L25="да")+($N25="да")+($P25="да"));0)

=ЕСЛИ(L25="да";$D$14/СЧЁТЕСЛИ($L$25:$L$55;"да")-1*(ЕСЛИ(H25="да";$D$6/СЧЁТЕСЛИ($H$25:$H$55;"да");0)+ЕСЛИ(J25="да";$D$13/СЧЁТЕСЛИ($J$25:$J$55;"да");0)+ЕСЛИ(L25="да";$D$14/СЧЁТЕСЛИ($L$25:$L$55;"да");0)+ЕСЛИ(N25="да";$D$15/СЧЁТЕСЛИ($N$25:$N$55;"да");0)+ЕСЛИ(P25="да";$D$16/СЧЁТЕСЛИ($P$25:$P$55;"да");0)-$D$17/ДЕНЬ(КОНМЕСЯЦА($B$1;0)))/(($H25="да")+($J25="да")+($L25="да")+($N25="да")+($P25="да"));0)

=ЕСЛИ(N25="да";$D$15/СЧЁТЕСЛИ($N$25:$N$55;"да")-1*(ЕСЛИ(H25="да";$D$6/СЧЁТЕСЛИ($H$25:$H$55;"да");0)+ЕСЛИ(J25="да";$D$13/СЧЁТЕСЛИ($J$25:$J$55;"да");0)+ЕСЛИ(L25="да";$D$14/СЧЁТЕСЛИ($L$25:$L$55;"да");0)+ЕСЛИ(N25="да";$D$15/СЧЁТЕСЛИ($N$25:$N$55;"да");0)+ЕСЛИ(P25="да";$D$16/СЧЁТЕСЛИ($P$25:$P$55;"да");0)-$D$17/ДЕНЬ(КОНМЕСЯЦА($B$1;0)))/(($H25="да")+($J25="да")+($L25="да")+($N25="да")+($P25="да"));0)

=ЕСЛИ(P25="да";$D$16/СЧЁТЕСЛИ($P$25:$P$55;"да")-1*(ЕСЛИ(H25="да";$D$6/СЧЁТЕСЛИ($H$25:$H$55;"да");0)+ЕСЛИ(J25="да";$D$13/СЧЁТЕСЛИ($J$25:$J$55;"да");0)+ЕСЛИ(L25="да";$D$14/СЧЁТЕСЛИ($L$25:$L$55;"да");0)+ЕСЛИ(N25="да";$D$15/СЧЁТЕСЛИ($N$25:$N$55;"да");0)+ЕСЛИ(P25="да";$D$16/СЧЁТЕСЛИ($P$25:$P$55;"да");0)-$D$17/ДЕНЬ(КОНМЕСЯЦА($B$1;0)))/(($H25="да")+($J25="да")+($L25="да")+($N25="да")+($P25="да"));0)

=C2+СУММЕСЛИМН(Нормативы!C:C;Нормативы!A:A;A:A;Нормативы!B:B;C:C)

Sub test2()
    Dim cl As Range, vv As Variant, dic As Object
    Set dic = CreateObject("Scripting.Dictionary")
    For Each cl In Intersect(Selection, ActiveSheet.UsedRange).Cells
        For Each vv In Split(cl.Value, " ")
            If vv <> "" Then dic(dic.Count) = vv
        Next
    Next
    If dic.Count = 0 Then Exit Sub
    Dim arr As Variant, ya As Long
    ReDim arr(1 To dic.Count, 1 To 1)
    For ya = 1 To UBound(arr, 1)
        arr(ya, 1) = dic.Items()(ya - 1)
    Next
    Selection.Cells(1, 2).Resize(UBound(arr, 1)).Value = arr
End Sub

Формула:       =СЧЁТЕСЛИ($A:$A;A3&"*")>1
Применяется к: =$A$2:$A$518

Sub myRnd()
    Do
        If Abs(Range("A1").Value - Range("A2").Value) < 0.1 Then Exit Do
        Range("A1").Calculate
        DoEvents
    Loop
End Sub

Option Explicit
 
Sub Разделить()
    Dim mySeparator As String
    mySeparator = InputBox("Какой символ будет разделителем?", "Выберите разделитель", ",")
    If mySeparator = "" Then Exit Sub
    
    Dim arr As Variant
    arr = GetArr(Selection, mySeparator)
    If IsEmpty(arr) Then Exit Sub
     
    PrintArray arr
End Sub
 
Private Sub PrintArray(arr As Variant)
    Dim rr As Range
    Set rr = ActiveSheet.UsedRange
    Set rr = rr.Rows(rr.Rows.Count + 2)
    Set rr = rr.Resize(UBound(arr, 1), UBound(arr, 2))
    rr.Value = arr
    SortRange rr
     
    Application.Goto rr
End Sub
 
Private Function GetArr(rr As Range, mySeparator As String) As Variant
    On Error Resume Next
    Set rr = Intersect(rr, rr.Parent.UsedRange)
    On Error GoTo 0
    If rr Is Nothing Then Exit Function
     
    Dim rArea As Range, arr As Variant, vv As Variant, ww As Variant
    Dim dic As Object
    Set dic = CreateObject("Scripting.Dictionary")
    For Each rArea In rr.Areas
        If rArea.Cells.CountLarge = 1 Then
            arr = Array(rArea.Value)
        Else
            arr = rArea.Value
        End If
        For Each vv In arr
            For Each ww In Split(vv, mySeparator)
                dic(Trim(ww)) = Empty
            Next
        Next
    Next
    If dic.Count = 0 Then Exit Function
    arr = dic.Keys()
    GetArr = TwoDimArr(arr)
End Function
 
Private Function TwoDimArr(arr As Variant) As Variant
    Dim brr As Variant
    ReDim brr(1 To UBound(arr) + 1, 1 To 1)
    Dim ya As Long
    For ya = LBound(arr) To UBound(arr)
        brr(ya + 1, 1) = arr(ya)
    Next
    TwoDimArr = brr
End Function
 
Private Sub SortRange(rr As Range)
    With rr.Parent.Sort
        .SortFields.Clear
        .SortFields.Add Key:=rr.Columns(1), SortOn:=xlSortOnValues, Order:=xlAscending, DataOption:=xlSortNormal
        .SetRange rr
        .Header = xlNo
        .MatchCase = False
        .Orientation = xlTopToBottom
        .SortMethod = xlPinYin
        .Apply
    End With
End Sub