Ping in Endlosschleife abfragen, stoppt nicht mehr

Sub CommandButton1_Click()
Dim rng As Range
If CommandButton1.Caption = "Start" Then
CommandButton1.Caption = "Stop"
Else
GoTo ende
End If
While CommandButton1.Caption = "Stop"
DoEvents
Set rng = Range("A2")
Do Until IsEmpty(rng.Value)
On Error Resume Next
v = Shell("cmd.exe /C ping " & rng.Value & ">C:\Ping" & rng.Value & ".txt")
If Err = 0 Then
Do
DoEvents
AppActivate v
Loop Until Err  0
On Error GoTo 0
Application.Wait 1000
Open "C:\Ping" & rng.Value & ".txt" For Input As #1
Do Until EOF(1)
Line Input #1, sTxt
If InStr(sTxt, "Verloren") Then
sTime = Right(sTxt, Len(sTxt) - InStr(sTxt, "Verloren") - 10)
sTime = Left(sTime, InStr(sTime, " (") - 1)
rng.Offset(0, 1).Value = sTime
End If
Loop
rng.Offset(0, 2).Value = "=NOW()"
rng.Offset(0, 2).Select
Selection.Copy
Selection.PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks _
:=False, Transpose:=False
Close #1
Else
rng.Offset(0, 1) = "Failed to shell"
End If
Set rng = rng.Offset(1, 0)
Loop
Wend
ende:
CommandButton1.Caption = "Start"
End Sub