Excel belirli zamanda macro çalıştırma

[hallarks]

Arkadaşlar merhaba,
Benim vba üzerinden oluşturduğum bi macro var macrom çok güzel bi şekilde istediğim gibi çalışıyor buraya kadar sorunum yok fakat yapmak istediğim bi durum var çok araştırdım fakat bulamadım, örnek; makroyu otomatik olarak tüm alanları seçip 10 dk sonra otomatik çalıştırmasını istiyorum böyle bişey vba üzerinden mümkün müdür ? ilgili görsel ve kodları bilginize sunarım.

Çalışma prensibi: bir sutunu seçip butona tıkladığınızda belirlemiş ip üzerinden o sunucuya ping atıyor eğer pingten cevap alırsa yeşil alamazsa kapalı diye kırmızı şekile dönüyor.

Sub GetIPStatus()

  Dim Cell As Range
  Dim ipRng As Range
  Dim result As String, IPString As String
  Dim IPSplit As Variant, IPSplit2 As Variant
  Dim rngArea As Range
  Dim arr() As String

On Error GoTo check
IPSplit = Split(Replace(Range("B2"), " ", "  "), ".")
            If Application.WorksheetFunction.CountA(IPSplit) > 2 Then
            IPString = Trim(Right(IPSplit(0), 3)) & "." & IPSplit(1) & "." & IPSplit(2) & "."
            End If
For Each rngArea In Selection
With rngArea

        'check does cell has hyperlink
        If .Hyperlinks.Count > 0 Then
        result = IsConnectible(.Value, 2, 4)
        If result Then
            .Interior.Color = RGB(0, 255, 0)
        Else
            .Interior.Color = RGB(255, 0, 0)
        End If
        GoTo NextIteration:
        End If

        If InStr(.Value, ".") > 0 Then
            If Len(.Value) - Len(Replace(.Value, ".", "")) = 3 Then 'if has 3 points like 192.168.1.2
               IPSplit2 = Split(rngArea, ".")
               If IsNumeric(IPSplit2(0) + IPSplit2(1) + IPSplit2(2) + IPSplit2(3)) Then
                            .Interior.ColorIndex = -4142
                    If Application.WorksheetFunction.Max(IPSplit2(0), IPSplit2(1), IPSplit2(2), IPSplit2(3)) < 256 And Application.WorksheetFunction.Min(IPSplit2(0), IPSplit2(1), IPSplit2(2), IPSplit2(3)) >= 0 Then
                        result = IsConnectible(.Value, 1, 4)
                        Debug.Print result
                        If result Then
                            .Interior.Color = RGB(0, 255, 0)
                        Else
                            .Interior.Color = RGB(255, 0, 0)
                        End If
                    End If
                    GoTo NextIteration:
                End If
            End If
    
        ElseIf InStr(.Value, ":") > 0 Then
                        result = IsConnectible(.Value, 2, 6)
                If result Then
                    .Interior.Color = RGB(0, 255, 0)
                Else
                    .Interior.Color = RGB(255, 0, 0)
                End If
            GoTo NextIteration:
    
        ElseIf IsNumeric(.Value) And rngArea <> "" Then  ' if it's number and if it's not blank
                    .Interior.ColorIndex = -4142
            If Len(Range("B2")) - Len(Replace(Range("B2"), ".", "")) > 2 Then
                If .Value = Int(.Value) And .Value < 256 And .Value >= 0 And .Offset(, 1).Font.Bold = False And .Offset(, 1).Value <> "broadcast" Then 'If cell is integer and cell on the right is not bold or broadcast
                    result = IsConnectible(IPString & .Value, 1, 4)
                        If result = "True" Then
                            .Interior.Color = RGB(0, 255, 0)
                          Else
                            .Interior.Color = RGB(255, 0, 0)
                        End If
                        GoTo NextIteration:
                End If
            ElseIf Len(Range("B2")) - Len(Replace(Range("B2"), ":", "")) > 2 Then
                    result = IsConnectible(Range("B2") & rngArea, 2, 6)
                     If result = "True" Then
                        .Interior.Color = RGB(0, 255, 0)
                    Else
                        .Interior.Color = RGB(255, 0, 0)
                    End If
                    GoTo NextIteration:
            End If
        End If
 
    End With
NextIteration:
Next rngArea

Exit Sub

check:
  MsgBox "Hata! Lütfen doğru ip seçiniz !'"
      
End Sub

Function IsConnectible(sHost, iPings, iPv)
    Dim nRes
   If iPings = "" Then iPings = 2 ' default number of pings
     With CreateObject("WScript.Shell")
          
     nRes = .Run("%comspec% /c ping.exe -" & iPv & " -n " & iPings & " " & sHost & " |  findstr ""TTL="" > nul 2>&1", 0, True)
          ' . is a wildcard
          ' it will search for string within Lost = n (xy% loss) but not (100% loss)
          
   End With
   IsConnectible = (nRes = 0)

End Function

 

[tacettinsal]

Örnek döküman olmadığı için detaylı bakamadım ancak zamanlama koyabilirsiniz. Vba arayüzünde çalışma kitabı kısmına aşağıdaki kodlarla deneme yapınız. İlgili çalışma kitabını açtıktan 10 dk sonra mevcutta bulunan GetIPStatus makrosunu çalıştırır.

Private Sub Workbook_Open()

Range("A1:A4,D4:D7,.....").Select '<--- Burada seçmek istediğiniz alanları giriniz.

Application.OnTime Now + TimeValue("00:10:00"), "GetIPStatus"

End Sub