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)
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