=ArrayFormula(QUERY(SPLIT(TRANSPOSE(SPLIT(TEXTJOIN("|",1,If(ROW(A8:A15)-LOOKUP(ROW(A8:A15),IF(A8:A15<>"",ROW(A8:A15)),ROW(A8:A15))<3,if(B8:I15<>"",LOOKUP(ROW(A8:A15),IF(A8:A15<>"",ROW(A8:A15)),A8:A15)&":"&IFERROR(VLOOKUP(B8:I15,I18:J22,2,),),""),"")),"|")),":"),"select Col1,sum(Col2) group by Col1 label Col1 'Пациент', sum(Col2) 'Сумма'",0))

=ArrayFormula(QUERY(SPLIT(TRANSPOSE(SPLIT(TEXTJOIN("|",1,If(ROW(A8:A15)-LOOKUP(ROW(A8:A15),IF(A8:A15<>"",ROW(A8:A15)),ROW(A8:A15))<3,if(B8:I15<>"",LOOKUP(ROW(A8:A15),IF(A8:A15<>"",ROW(A8:A15)),A8:A15)&":"&B8:I15,""),"")),"|")),":"),"select Col1,Col2,count(Col2) group by Col1,Col2 label Col1 'Пациент', Col2 'Процедура', count(Col2) 'Количество'",0))

=ArrayFormula({{"Пациент","Процедура","Стоимость"};SPLIT(TRANSPOSE(SPLIT(TEXTJOIN("|",1,If(ROW(A8:A15)-LOOKUP(ROW(A8:A15),IF(A8:A15<>"",ROW(A8:A15)),ROW(A8:A15))<3,if(B8:I15<>"",LOOKUP(ROW(A8:A15),IF(A8:A15<>"",ROW(A8:A15)),A8:A15)&":"&B8:I15&":"&VLOOKUP(B8:I15,I18:J22,2,),""),"")),"|")),":")})

Dim i&
For Each obj In Sheets(2).OLEObjects
    i = i - (obj.progID = "Forms.ToggleButton.1" And obj.Object)
Next

a=координаты верхней границы 1 фигуры
b=координаты нижней границы 1 фигуры
с=координаты левой границы 1 фигуры
d=координаты правой границы 1 фигуры
e=координаты верхней границы 2 фигуры
f=координаты нижней границы 2 фигуры
g=координаты левой границы 2 фигуры
h=координаты правой границы 2 фигуры
i=application.median(a,b,e,f)
j=application.median(c,d,g,h)
If i < a And i > b And j > c And j < d then Надвинуто=true

dim фигура2 as shape
with activesheet
    with .shapes("Овал 1")
        'вычисление координат границ Овала 1
    end with
    'проход циклом по объектам в коллекции shapes
    for each фигура2 in .shapes
        if фигура2.name<>"Овал 1" then
           'вычисление координат границ фигуры2 и пересечения с овалом
        endif
    next
end with

redim preserve

Sub Макрос1()
    Dim фигура2 As Shape
    With ActiveSheet
        With .Shapes("Овал 1")
            'вычисление координат границ Овала 1
            'Здесь контекст- ActiveSheet.Shapes("Овал 1") , поэтому следующие 4 строчки отрабатывают корректно
            a = .Top
            b = .Top + .Height
            c = .Left
            d = .Left + .Width
        End With
        'проход фиклом по объектам в коллекции shapes
        For Each фигура2 In .Shapes
            If фигура2.Name <> "Овал 1" Then
                'вычисление координат границ фигуры2 и пересечения с овалом
                'а вот здесь контекст - activesheet и следующие 4 не будут работать (в классе worksheet нету свосйтв top и left)
                'чтобы работало нужно или обернуть их в конструкцию with фигура2 ... end with, или писать e=фигура2.top
                e = .Top
                f = .Top + .Height
                g = .Left
                h = .Left + .Width
                i = Application.Median(a, b, e, f)
                j = Application.Median(c, d, g, h)
                If i < a And i > b And j > c And j < d Then Надвинуто = True
            End If
        Next
    End With
End Sub

Option Explicit
Sub DetectIntersection()
    Dim a&, b&, c&, d&, e&, f&, g&, h&, i&, j&, k%, arr$(), Фигура2 As Object, sCallerName$
    Const ShName$ = "Oval 1" 'имя Фигуры1
    With Application
        'если макрос был запущен нажатием на шейп, пишем в переменную имя этого шейпа
        If TypeName(.Caller) = "Shape" Then sCallerName = .Caller.Name
        With ActiveSheet 'контекст - активный лист, (все вызовы .Свойство или .Метод на этом уровне вложенности обращаются к нему)
            With .Shapes(ShName) 'контекст - Шейп с именем ShName
                'вычисление координат границ Фигуры1
                a = .Top: b = a + .Height
                c = .Left: d = c + .Width
            End With ' co следующей строки контекст снова активный лист
            'проход циклом по объектам в коллекции shapes
            For Each Фигура2 In .Shapes
                'Если имя Фигуры1 <> имени Фигуры1 и <> sCallerName (имя шейпа, если этот макрос был запущен кликом по нему)
                If Фигура2.Name <> ShName And Фигура2.Name <> sCallerName Then
                    With Фигура2 'контекст - Фигура2
                        e = .Top: f = .Top + .Height
                        g = .Left: h = .Left + .Width
                    End With ' co следующей строки контекст снова активный лист
                    'вычисления медиан вертикальных и горизонтальных координат Фигуры1 и Фигуры2
                    i = Application.Median(a, b, f, e)
                    j = Application.Median(c, d, g, h)
                    'если точка с координатами = полученных медиан находится внутри шейпа ShName
                    If i > a And i < b And j > c And j < d Then
                        'Переопределяем размерность массива
                        ReDim Preserve arr(k)
                        'пишем в последний элемент массива имя Фигуры2
                        arr(k) = Фигура2.Name
                        k = k + 1
                    End If
                End If
            Next
            'область непустых ячеек, граничащих с N4
            With .[N4].CurrentRegion
                'смещаемся на 1 ячейку вниз и выбираем столбец N
                With Intersect(.Cells, .Offset(1), .Parent.Columns("N"))
                    'Очищаем значения выбранных ячеек
                    On Error Resume Next
                    .ClearContents
                    On Error GoTo 0
                End With
                'пишем новые значения из массива arr, если он не пуст
                If i Then .Offset(1).Resize(k).Value = Application.Transpose(arr)
            End With
        End With
    End With
End Sub

dim bool as Boolean
        bool = Application.AutoCorrect.AutoFillFormulasInLists
        Application.AutoCorrect.AutoFillFormulasInLists = False

Application.AutoCorrect.AutoFillFormulasInLists = bool

Sub Date_And_Time_GAZ_2()
    Dim start_time As Date, i As Integer, Arr(), bool As Boolean, calc&
    
    start_time = InputBox("Введите дату, с которой начнётся таблица. Например 01.01.2019")
    Arr = [transpose(transpose(mod(row(r1:r24),24)))/24]
    With Application
        bool = .AutoCorrect.AutoFillFormulasInLists
        .AutoCorrect.AutoFillFormulasInLists = False: calc = .Calculation
        .ScreenUpdating = 0: .EnableEvents = 0: .Calculation = xlCalculationManual
        With .ActiveSheet.ListObjects.Add(xlSrcRange, Range(Cells(1, 1), Cells(10010, 10)), , xlNo)
            .Name = "ГАЗ"
            For i = 2 To (.ListRows.Count \ 24) * 24 Step 24
                With .ListColumns(1).Range.Cells(i)
                    .Value = start_time + i \ 24
                    With .Offset(, 1).Resize(24)
                        .Value = Arr
                        .NumberFormat = "hh:mm"
                    End With
                    .Offset(23, 2).Resize(, 5).Borders(xlEdgeBottom).Weight = xlThick
                    With .Offset(23, 7).Resize(, 3)
                        .Interior.ColorIndex = 27
                        .Borders.Weight = xlThick
                        .Cells(1, 3).FormulaR1C1 = "= RC[-2]+RC[-1]"
                    End With
                End With
            Next
        End With
        Application.AutoCorrect.AutoFillFormulasInLists = bool
        .ScreenUpdating = 1: .EnableEvents = 1: .Calculation = calc
    End With
End Sub

Sub Вариант_1()
    Dim c_x1y1 As Range, c_x2y2 As Range, x#, y#, i%, h#
    
    lastcol = Cells(2, Columns.Count).End(xlToLeft).Column
    
    Set c_x1y1 = Range(Cells(2, 2), Cells(3, lastcol))
    Set c_x2y2 = Range(Cells(6, 2), Cells(7, lastcol))
    
    With ActiveSheet.Shapes
        On Error Resume Next
        i = 1
        Do While Err = 0
            .Item("line " & i).Delete
            .Item("label " & i).Delete
            i = i + 1
        Loop
        On Error GoTo 0
        For i = 1 To lastcol - 1
            x = c_x1y1(1, i) + (c_x2y2(1, i) - c_x1y1(1, i) - c_x1y1(1, 1).Width) / 2
            y = c_x1y1(2, i) + (c_x2y2(2, i) - c_x1y1(2, i) - c_x1y1(7, 1).Height) / 2
            With .AddConnector(1, c_x1y1(1, i), c_x1y1(2, i), c_x2y2(1, i), c_x2y2(2, i))
                .Name = "line " & i
            End With
            With .AddTextbox(1, x, y, c_x1y1(1, i).Width, c_x1y1(7, i).Height)
                .Name = "label " & i
                h = .Height
                With .TextFrame
                    .Characters.Text = c_x1y1(7, i)
                    .HorizontalAlignment = xlHAlignCenter
                    .VerticalAlignment = xlVAlignCenter
                    .MarginBottom = 0: .MarginLeft = 0
                    .MarginRight = 0: .MarginTop = 0
                    .AutoSize = True
                End With
                If .Height <> h Then .Top = .Top - (.Height - h) / 2
            End With
        Next i
    End With
End Sub