Dim i&, j As Variant
    With ActiveSheet.UsedRange
        With Intersect(.Offset(5), .Cells)
            arr = .Value
            For i = LBound(arr, 1) To UBound(arr, 1)
                For Each j In Array(17, 26)
                    Macr = arr(i, j - .Column + 1)
                    If Macr <> "" Then
                        Application.Run Macr
                        Application.Wait Now + #12:00:05 AM#
                    End If
            Next j, i
        End With
    End With

    Dim r As Range, col As Variant
    With ActiveSheet.UsedRange
        With Intersect(.Offset(5), .Cells)
            For Each r In .Rows
                For Each col In Array("Q", "Z")
                    Macr = r.Columns(col).Value
                    If Macr <> "" Then
                        Application.Run Macr
                        Application.Wait Now + #12:00:05 AM#
                    End If
            Next col, r
        End With
    End With

Sub Овал1_Щелчок()
Dim arr As Collection, x, t, i
Set arr = New Collection
For Each x In Range(Cells(6, 17), Cells(Rows.Count, 17).End(xlUp))
arr.Add x.Value
arr.Add ActiveSheet.Cells(x.Row, 9 + x.Column).Value
Next x
    'arr = Range(Cells(6, 17), Cells(Rows.Count, 17).End(xlUp)).Value
        For i = 1 To arr.Count
            If Not IsEmpty(arr(i)) Then
                If i / 2 = Int(i / 2) Then Macr = "J" & (5 + i) Else Macr = "S" & (5 + i)
                Application.Run arr.Item(i)
                t = Now + TimeValue("0:00:05")
                    Do
                        DoEvents
                    Loop While t > Now
            End If
        Next i
Set arr = Nothing
End Sub

     Set shp = ActiveSheet.Shapes.AddPicture(Range(Macr), False, True, -1, -1, -1, -1)