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

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

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

redim preserve

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

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 i&
For Each obj In Sheets(2).OLEObjects
    i = i - (obj.progID = "Forms.ToggleButton.1" And obj.Object)
Next

=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,),""),"")),"|")),":")})

=ПОДСТАВИТЬ(СЖПРОБЕЛЫ(ПОДСТАВИТЬ(stringRegExpReplace(A2;"[\s\S]*?((?:[\w\d]{1,4}\.){4}(?:[\w\d&]{5,6}\.){2}\d{3}\.DC\.\d{4})|[\s\S]";"$1,";1;1;1);",";" "));" ";", ")

Private Sub Workbook_BeforeClose(Cancel As Boolean)
    Evaluate("Кнопка 5").OnAction = "test"
End Sub

Evaluate("Кнопка 5").OnAction = "test"

Sub sortirovka() 'Раскрытие таблицы
    Dim r As Range, i&, j&, v As Variant, arr() As Variant
    With [Таблица1].ListObject
        With .Range.CurrentRegion
            If .Rows.Count < 2 Then Exit Sub
            ReDim Preserve arr(1 To .Rows.Count - 1, 1 To .Columns.Count)
            For j = 1 To .Columns.Count
                For Each r In .Columns(j)
                    i = 1
                    For Each v In BubbleSort(Intersect(r, r.Offset(1)).Value)
                        arr(i, j) = v
                        i = i + 1
            Next v, r, j
            Intersect(.Offset(1), .Cells).ClearContents
            .Cells(2, 1).Resize(i - 1, j - 1) = arr
        End With
        .Resize .Range.CurrentRegion
    End With
End Sub
Function BubbleSort(v As Variant) As Variant
    Dim i&, j&, b As Boolean
    If Not IsArray(v) Then BubbleSort = Array(v): Exit Function
    b = UBound(v) >= UBound(v, 2)
    For i = 1 To UBound(v, IIf(b, 1, 2)) - 1: For j = i To UBound(v, IIf(b, 1, 2))
        swap v(IIf(b, i, 1), IIf(b, 1, i)), v(IIf(b, j, 1), IIf(b, 1, j))
    Next j, i
    BubbleSort = v
End Function
Sub swap(ByRef a As Variant, b As Variant)
    If a < b Xor (a <> "") And (b <> "") Then: Dim c: c = a: a = b: b = c
End Sub

Option Explicit
Dim b As Boolean

...

Sub Obj1ToObj2_1(Obj1, Obj2, Optional Steps = 20)
  Const dt# = 0.02
  Dim x1#, x2#, y1#, y2#, x#, y#, t!
  Dim l1#, t1#, w1#, h1#, l2#, t2#, w2#, h2#
  Do: t = Timer: Do: DoEvents: Loop While Timer < t + dt: Loop While b
  With Obj1
    l1 = .Left: t1 = .Top: w1 = .Width: h1 = .Height
  End With
  l2 = Obj2(1, 1): t2 = Obj2(1, 2)
'  With Obj2
'    l2 = .Left: t2 = .Top: w2 = .Width: h2 = .Height
'  End With
  x1 = l1 + w1 / 2
  y1 = t1 + h1 / 2
  x2 = l2 ' + w2 / 2
  y2 = t2 ' + h2 / 2
  With Obj1
    For x = x1 To x2 Step (x2 - x1) / Steps
      y = (x2 * y1 - x1 * y2 - (y1 - y2) * x) / (x2 - x1)
      .Left = x - w1 / 2
      .Top = y - h1 / 2
      t = Timer + dt
      While Timer < t:  Wend
      DoEvents:
    Next
    x = x2: y = y2: .Left = x - w1 / 2: .Top = y - h1 / 2
  End With
  b = True
End Sub
Sub test()
    Dim lr&, i&, sTmp$
    On Error Resume goto err
    With Evaluate(Application.Caller)
        sTmp$ = .OnAction
        .OnAction = "toggle"
        With Лист1
            lr = .Cells(Rows.Count, "n").End(xlUp).Row
            For i = 6 To lr
                Obj1ToObj2_1 .Shapes("Oval 1"), .Cells(i, "n").Resize(, 2).Value
            Next i
        End With
err:    .OnAction = sTmp
    End With
    MsgBox "Конец"
End Sub
Private Sub toggle()
    b = Not b
End Sub