Error with vba code for ping IP adress

[FvdF]

Dear forum readers,

I have this vba code but it does not work for me. Get an error message and do not know what goes wrong.

Work with Dutch Excel 2019!

With Regards,
FvdF

Function Ping(strip)
Dim objshell, boolcode
Set objshell = CreateObject("Wscript.Shell")
boolcode = objshell.Run("ping -n 1 -w 1000 " & strip, 0, True)
If boolcode = 0 Then
    Ping = True
Else
    Ping = False
End If
End Function

Sub PingSystem()
Dim strip As String
[COLOR=rgb(184, 49, 47)]Do Until Sheet1.Range("F1").Value = "STOP"[/COLOR]
Sheet1.Range("F1").Value = "TESTING"
For introw = 2 To ActiveSheet.Cells(65536, 2).End(xlUp).Row
    strip = ActiveSheet.Cells(introw, 2).Value
    If Ping(strip) = True Then
        ActiveSheet.Cells(introw, 3).Interior.ColorIndex = 0
        ActiveSheet.Cells(introw, 3).Font.Color = RGB(0, 0, 0)
        ActiveSheet.Cells(introw, 3).Value = "Online"
        Application.Wait (Now + TimeValue("0:00:01"))
        ActiveSheet.Cells(introw, 3).Font.Color = RGB(0, 200, 0)
    Else
        ActiveSheet.Cells(introw, 3).Interior.ColorIndex = 0
        ActiveSheet.Cells(introw, 3).Font.Color = RGB(200, 0, 0)
        ActiveSheet.Cells(introw, 3).Value = "Offline"
        Application.Wait (Now + TimeValue("0:00:01"))
        ActiveSheet.Cells(introw, 3).Interior.ColorIndex = 6
    End If
If Sheet1.Range("F1").Value = "STOP" Then
        Exit For
End If
Next
Loop
Sheet1.Range("F1").Value = "IDLE"
End Sub

Sub stop_ping()
    Sheet1.Range("F1").Value = "STOP"
End Sub

PingTool.xlsm
	A	B	C	D	E	F	G	H	I	J
1	Name	Adress	Ping Status			STOP
2	vip5202_f15184.home	192.168.2.2	Online
3	l2710dw.home	192.168.2.4
4	nu.nl	2.19.195.227
5	telegraaf.nl	104.18.21.245
6	bbc.nl	188.114.96.0
7	google.nl	142.251.39.99
8	amazon.nl	52.95.116.117
9
Blad1

 

[Dan_W]

Hi. Should be solvable - what is the error number, what is the error message, and on what line is the error occurring?

 

[Marc L]

Hi, according to Excel 2003, 2007, 2010 versions, removing the useless, a VBA demonstration for starters :​

Sub Demo1()
             Dim Rc As Range
    With CreateObject("WScript.Shell")
        For Each Rc In Range("B2:B" & [A1].CurrentRegion.Rows.Count)
            Rc(1, 2).Value2 = Array("Ok", "Off")(.Run("ping -n 1 -w 1000 " & Rc.Text, 0, True))
            Rc(1, 2).Font.Color = Array(vbRed, vbGreen)(-(Rc(1, 2).Text= "Ok"))
        Next
    End With
End Sub