Error with vba code for ping IP adress

FvdF

New Member
Joined
Oct 19, 2020
Messages
3
Office Version
  1. 2019
  2. 2016
Platform
  1. Windows
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


VBA Code:
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
ABCDEFGHIJ
1NameAdressPing StatusSTOP
2vip5202_f15184.home192.168.2.2Online
3l2710dw.home192.168.2.4
4nu.nl2.19.195.227
5telegraaf.nl104.18.21.245
6bbc.nl188.114.96.0
7google.nl142.251.39.99
8amazon.nl52.95.116.117
9
Blad1
 

Excel Facts

How to change case of text in Excel?
Use =UPPER() for upper case, =LOWER() for lower case, and =PROPER() for proper case. PROPER won't capitalize second c in Mccartney
Hi. Should be solvable - what is the error number, what is the error message, and on what line is the error occurring?
 
Upvote 0
Hi, according to Excel 2003, 2007, 2010 versions, removing the useless, a VBA demonstration for starters :​
VBA Code:
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
 
Last edited:
Upvote 0

Forum statistics

Threads
1,213,528
Messages
6,114,154
Members
448,553
Latest member
slaytonpa

We've detected that you are using an adblocker.

We have a great community of people providing Excel help here, but the hosting costs are enormous. You can help keep this site running by allowing ads on MrExcel.com.
Allow Ads at MrExcel

Which adblocker are you using?

Disable AdBlock

Follow these easy steps to disable AdBlock

1)Click on the icon in the browser’s toolbar.
2)Click on the icon in the browser’s toolbar.
2)Click on the "Pause on this site" option.
Go back

Disable AdBlock Plus

Follow these easy steps to disable AdBlock Plus

1)Click on the icon in the browser’s toolbar.
2)Click on the toggle to disable it for "mrexcel.com".
Go back

Disable uBlock Origin

Follow these easy steps to disable uBlock Origin

1)Click on the icon in the browser’s toolbar.
2)Click on the "Power" button.
3)Click on the "Refresh" button.
Go back

Disable uBlock

Follow these easy steps to disable uBlock

1)Click on the icon in the browser’s toolbar.
2)Click on the "Power" button.
3)Click on the "Refresh" button.
Go back
Back
Top