Limitar tiempo de ejecucion

Buenas a todos, tengo una macro que busca en varios equipos remotos un archivo y lo lee para buscar una información especifica en el, el problema seria cuando no logra conectarse a un equipo tarda mucho antes de seguir al siguiente, quisiera limitar el tiempo en el que trata de conectarse a 3 segundos, mejor dicho que el programa se interrumpa y siga con el siguiente cada 3 segundos.

les dejo el codigo a ver en que me pueden ayudar:

Sub RevArchivo()

    Dim Ruta(5000) As String

    Dim c

    Dim i

    Dim r

    Dim fin

    Dim lectura As String

    Dim Origen As Long

    Dim Archivo As String

    Dim Respuesta(5000)

    Dim p

    Dim v

    Dim StartTime

    Dim StopTime

    Dim MinutsTime


    v = 0

    p = 0

    r = 0




    Application.ScreenUpdating = False

    Application.EnableEvents = False

    ActiveSheet.DisplayPageBreaks = False

    'Application.DisplayStatusBar = True



    For i = 2 To 3000



        If Sheets("Revision").Cells(i, 2) = "" Then


        c = i - 1


        i = 30001


        End If




    Next


    For i = 2 To c


        Ruta(r) = Sheets("Revision").Cells(i, 2)


        r = r + 1


    Next





    'MsgBox c & " ATMs"


    For i = 0 To r


    StartTime = Timer


    Application.StatusBar = "Comprobando " & i & "/" & r


    Archivo = Ruta(i)



    Origen = FreeFile




    Set objFSO = CreateObject("Scripting.FileSystemObject")

        If objFSO.FileExists(Archivo) Then




            Open Archivo For Input As #Origen


                Do While Seek(Origen) <= LOF(Origen)


                Line Input #Origen, lectura


                lectura = Application.Trim(lectura)


                    If Mid(lectura, 1, 4) = "<h2>" Then

                        Respuesta(i) = Mid(lectura, 2, 43)

                        v = 1

                        'MsgBox Respuesta(i)

                    Else

                        If v <> 1 Then

                            Respuesta(i) = "No encontrado"

                        End If

                    End If




                Loop


                Close #Origen


        Else


            Respuesta(i) = "Error Archivo No Encontrado"


        End If


        StopTime = Timer


        MinutsTime = StopTime - StartTime


        If MinutsTime > 3 Then


            Application.Wait Now() + TimeValue("00:00:02")


        End If


    Next


    p = r


    r = 0


    For i = 2 To c


    Application.StatusBar = "Generando Listado " & i - 1 & "/" & p


        Sheets("Revision").Cells(i, 3) = Respuesta(r)

    r = r + 1


    Next


    Application.StatusBar = ""

    Application.ScreenUpdating = True

    Application.EnableEvents = True

    ActiveSheet.DisplayPageBreaks = True



End Sub[/CODE]