请教如何让这个程序每次运行10遍并自动赋值

gzminge

现在有下面这个程序，希望通过修改能达到这样的要求：
1.每次能连续运行10遍，完成后显示对话框“10次完成”
2.每运行1遍就自动给Range("AR1268")赋值，在原来的数值上+1.


Sub 每天()
    Dim r%, i%
    Dim arr, brr
    Dim d As Object
    Set d = CreateObject("scripting.dictionary")
    ts = Application.InputBox(prompt:="请输入相隔天数", Title:="操作提示", Default:=Range("AR1268"), Type:=1)
    With ActiveSheet
        r = .Cells(.Rows.Count, 1).End(xlUp).Row
        .Range("c3:v" & r).Interior.Color = 16772537
        arr = .Range("c3:v" & r)
        ReDim brr(1 To UBound(arr), 1 To UBound(arr, 2))
        For i = 1 To UBound(arr) - ts - 1
            d.RemoveAll
            For j = 1 To UBound(arr, 2)
                d(arr(i + ts + 1, j)) = Empty
            Next
            n = 0
            For j = 1 To UBound(arr, 2)
                If d.exists(arr(i, j)) Then
                    .Cells(i + 2, j + 2).Interior.ColorIndex = 3
                    n = n + 1
                    brr(i, n) = j
                End If
            Next
        Next
        .Range("x3").Resize(UBound(brr), UBound(brr, 2)) = brr
    End With
   
    Sheets("  0  ").Select
   
    Range("Y1:AT25").Select
    Selection.Copy
   
    Windows("能定（1）.xlsm").Activate
   
  Dim searchRange As Range
  Set searchRange = Range("AG2484:AG50000")

  Dim findValue As Variant
  findValue = "999"

  Dim resultCell As Range
  Set resultCell = searchRange.Find(findValue)

  resultCell.Select
  Selection.PasteSpecial Paste:=xlPasteValues, Operation:=xlPasteSpecialOperationNone, SkipBlanks:=False, Transpose:=False

    Windows("必离（9）.xlsm").Activate
    Sheets("每天").Activate
    Range("AR1268").Select

End Sub