Sub sortirovka() 'Раскрытие таблицы
    Dim b As Boolean, r As Range, col as range
    With [Таблица1].ListObject
        Set r = .Range.CurrentRegion
        For Each col In r.Columns
            If col.Column = r.Column Then
                .Resize col.Next.Resize(2)
            ElseIf Not b Then
                b = True
                .Resize r.Resize(2, 2)
                .Resize r.Resize(2, 1)
            End If
            With Intersect(.Parent.UsedRange, col.EntireColumn)
                .sort .Cells(1), xlAscending, Header:=1
            End With
        Next
        .Resize r.Resize(r.Rows.Count - IsEmpty(r.Cells(2, 1)))
    End With
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

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

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

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

=ПОДСТАВИТЬ(СЖПРОБЕЛЫ(ПОДСТАВИТЬ(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);",";" "));" ";", ")

=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