=G3-F3-ОТБР((G3-ОКРВНИЗ(F3-8;7)-8)/7)

dd()
    With ActiveSheet.UsedRange
        With Intersect(.SpecialCells(xlCellTypeConstants, 23).EntireRow, .Columns)
            .SpecialCells(xlCellTypeBlanks).FormulaR1C1 = "=R[-1]C1"
        End With
        .Formula = .Value
        .Columns(1).SpecialCells(xlCellTypeBlanks).EntireRow.Delete
        .Cut [A1]
    End With
End Sub

Sub ss()

Sheets("Лист2").Select
lr = Sheets("Лист1").Cells(Rows.Count, 1).End(xlUp).Row
lr2 = Sheets("Лист2").Cells(Rows.Count, 1).End(xlUp).Row
For i = 1 To lr2
On Error Resume Next
V = Sheets("Лист2").Cells(i, 1).Value
m = Application.WorksheetFunction.VLookup(V, Sheets("Лист1").Range("A1:B" & lr2), 2, False)

If Not IsEmpty(m) Then Cells(i, 2).Value = Cells(i, 2).Value - m

Next i

End Sub

Sub ss()
    Dim i&, m As Variant
    With Sheets("Лист2")
        For Each v In .[A1].CurrentRegion.Columns(1).Value
            i = i + 1
            m = Application.VLookup(v, Sheets("Лист1").[A1].CurrentRegion, 2, False)
            With .Cells(i, 2)
            If Not IsEmpty(m) Then .Value = .Value - m
            End With
        Next
    End With
End Sub

Sub sdf()
    Dim Dic As Object
    Dim sh As Worksheet
    Dim r As Range, w As Range, c As Range
    Dim arr() As Variant, arr1 As Variant
    Dim i, j, k, l, m, n, o
    
    Set Dic = CreateObject("scripting.dictionary")
    For Each w In Sheets("Criteria").Cells.SpecialCells(xlCellTypeConstants, 1).Areas
        With w.Offset(-1, -1).Resize(1, 1)
            n = Abs(Mid(.Value, InStrRev(.Value, "(")))
        End With
        For Each c In w.Offset(, -1)
            Dic(n & "_" & c) = c.Offset(, 1)
        Next
    Next
    With Sheets("Result(было)")
        m = .UsedRange.Columns.Count
        n = .Columns(1).SpecialCells(xlCellTypeConstants, 23).Areas.Count
        Set r = .[A1].CurrentRegion
        ReDim arr(1 To n * m, 1 To 6)
        For i = 1 To n
            For j = 1 To m
                o = (i - 1) * m + j
                If Not IsEmpty(r(1, j)) Then
                    For k = 1 To 3
                       arr(o, k) = r(k, j)
                    Next
                    l = 0
                    For k = 4 To r.Rows.Count
                        l = l + Dic(arr(o, 2) & "_" & r(k, j))
                    Next
                    If l Then arr(o, 5) = l
                    s = ""
                    On Error Resume Next
                    With r.Columns(j)
                        arr1 = Intersect(.Offset(3), .Cells).SpecialCells(xlCellTypeConstants, 23)
                        If IsArray(arr1) Then
                            s = Join(Application.Transpose(arr1), "_")
                        ElseIf Not IsEmpty(arr1) Then
                            s = arr1
                        End If
                        Erase arr1
                    End With
                    arr(o, 6) = s
                End If
            Next
            Set r = r.End(xlDown).End(xlDown).CurrentRegion
            n = n + 1
        Next
    End With
    Application.ScreenUpdating = 0: Application.EnableEvents = 0
    With Sheets("+++++").UsedRange
        Intersect(.Offset(1), .Cells).Clear
        .Cells(4, 1).Resize(o, 6).Value = arr
    End With
    Application.ScreenUpdating = 1: Application.EnableEvents = 1
    Set Dic = Nothing
    Set r = Nothing
    Set w = Nothing
    Set c = Nothing
    Erase arr
End Sub

=СТРОКА()-СТРОКА([#Заголовки])

=ОСТАТ(10-ОСТАТ(СУММ(--ПСТР(A1;{2;4;6};1);ПСТР(A1;{1;3;5;7};1)*3);10);10)

Sub ExportToXML()
    Dim strPath As String, sTmp As String
    strPath = ThisWorkbook.Path & "\счет.xml"
    ThisWorkbook.XmlMaps("Файл_карта").Export URL:=strPath
    DoEvents
    With CreateObject("ADODB.Stream")
        .Type = 2: .Charset = "utf-8"
        .Open: .LoadFromFile strPath: sTmp = .ReadText: .Close
        .Charset = "windows-1251": sTmp = Replace(sTmp, "UTF-8", "windows-1251")
        .Open: .WriteText sTmp: .SaveToFile strPath, 2: .Close
    End With
End Sub

=(МУМНОЖ(ОТБР(A2:B2);{-1:1})*12-МУМНОЖ(-ТЕКСТ(ТЕКСТ(ОСТАТ(A2:B2;1)*24;"[>20]2\0");"[<8]8");{-1:1}))/24

=((ОТБР(B2)-ОТБР(A2))*12-СУММ(ТЕКСТ(ТЕКСТ(ОСТАТ(A2:B2;1)*24;"[>20]2\0");"[<8]8")*{1;-1}))/24

Option Explicit

Sub ertert()
Dim wsh As Worksheet, dt As Date, x, y(), i&, k&
dt = Range("A1").Value
Intersect(ActiveSheet.UsedRange.Offset(1), [B:F]).ClearContents

For Each wsh In ThisWorkbook.Sheets
    If Not wsh Is ActiveSheet Then
        x = wsh.Range("I1").CurrentRegion.Value
        If Not IsEmpty(x) Then
            k = 0
            ReDim y(1 To UBound(x), 1 To 5)
            For i = 1 To UBound(x) Step 2
                If x(i, 1) = dt Then
                    k = k + 1
                    y(k, 1) = dt
                    y(k, 2) = x(i + 1, 1)
                    y(k, 3) = x(i, 2)
                    y(k, 4) = x(i + 1, 2)
                    y(k, 5) = wsh.Name
                End If
            Next i
            If k > 0 Then Cells(Rows.Count, 2).End(xlUp)(2, 1).Resize(k, 5).Value = y()
        End If
    End If
Next wsh

With Range("B1:F" & Cells(Rows.Count, 2).End(xlUp).Row)
    .Sort Key1:=.Cells(1, 1), Order1:=xlAscending, _
        Key2:=.Cells(1, 2), Order2:=xlAscending, Header:=xlYes
End With
End Sub

Sub ertert()
Dim wsh As Worksheet, dt As Date, x, y(), i&, k&
dt = Range("A1").Value
Range("A1").CurrentRegion.Offset(1).ClearContents

For Each wsh In ThisWorkbook.Sheets
    If Not wsh Is ActiveSheet Then
        x = wsh.Range("I1").CurrentRegion.Value
        If Not IsEmpty(x) Then
            k = 0
            ReDim y(1 To UBound(x), 1 To 5)
            For i = 1 To UBound(x) Step 2
                If x(i, 1) = dt Then
                    k = k + 1
                    y(k, 1) = dt
                    y(k, 2) = x(i + 1, 1)
                    y(k, 3) = x(i, 2)
                    y(k, 4) = x(i + 1, 2)
                    y(k, 5) = wsh.Name
                End If
            Next i
            If k > 0 Then Cells(Rows.Count, 2).End(xlUp)(2, 1).Resize(k, 5).Value = y()
        End If
    End If
Next wsh

With Range("B1:F" & Cells(Rows.Count, 2).End(xlUp).Row)
    .Sort Key1:=.Cells(1, 1), Order1:=xlAscending, _
          Key2:=.Cells(1, 2), Order2:=xlAscending, Header:=xlYes
End With
End Sub

Function Перенос$(s$)
    With CreateObject("vbscript.regexp")
        .Pattern = "(\d{1,3}(?=\d{4}))|\d+"
        .Global = True
        s = .Replace(StrReverse(s), "$1 ")
    End With
    Перенос = StrReverse(Application.Trim(s))
End Function

Option Explicit

Private LO As ListObject
Private index%

Private Sub UserForm_QueryClose(Cancel As Integer, CloseMode As Integer)
    Set LO = Nothing
End Sub

Private Sub ИмяПациента_Change()

End Sub

Private Sub ИмяТовара_Change()

End Sub

Private Sub КачествоТовара_Change()

End Sub

Private Sub КоличествоТовара_Change()

End Sub

Private Sub UserForm_Initialize()
    Set LO = [Таблица2].ListObject
    With LO
        If Intersect(.DataBodyRange, Selection) Is Nothing Then
            Set LO = Nothing
            Exit Sub
        End If
        index = Selection.Row - .HeaderRowRange.Row
        With .ListColumns
            Me.ИмяПациента = .Item("Имя").DataBodyRange(index)
            Me.ИмяТовара = .Item("Товар").DataBodyRange(index)
            Me.КоличествоТовара = .Item("Количество").DataBodyRange(index)
            Me.КачествоТовара = .Item("Качество").DataBodyRange(index)
        End With
    End With
End Sub

Private Sub Редактура_Click()
    LO.ListRows(index).Range = Array(ИмяПациента, ИмяТовара, КоличествоТовара, КачествоТовара)
End Sub

Private Sub ОчисткаФормы_Click()
    Me.ИмяПациента = Empty
    Me.ИмяТовара = Empty
    Me.КоличествоТовара = Empty
    Me.КачествоТовара = Empty
End Sub

Private Sub СозданиеНового_Click()
    LO.ListRows.Add.Range = Array(ИмяПациента, ИмяТовара, КоличествоТовара, КачествоТовара)
End Sub

Private Sub Выход_Click()
    Unload Me
End Sub

=C2=КОНМЕСЯЦА(B2;0)+1