Ping to a port using VBA RRS feed

  • Question

  • Hi,

    I have some VBA script that I am using to ping a list of IP addresses and provide a result in another column. It works almost exactly as I want it to except I need to ping a port and not an IP due to my devices all being remote. The script also provides the tested IP address in column B and I would this to be a hyperlink so that I can browse directly to the device.

    Option Explicit
    Sub PingTest()
    Dim URL, IPAddr As String, SiteName As String, i As Integer
    Dim URLs As Range, objShell, objCommand, strCommand, strPingResult, arrIPAddress, strIPAddress
    If Range("A" & Rows.Count).End(xlUp).Row <= 1 Then
        MsgBox "No URLs listed under Column 'A'," & vbCrLf & "Input URLs and try again.", vbCritical, "Missing Input"
        Exit Sub
    End If
    Set URLs = Range("A2:A" & Range("A" & Rows.Count).End(xlUp).Row)
    Set objShell = CreateObject("WScript.Shell")
    'ping -n 1 -w 300 | Findstr /B /C:"Reply from"
    i = 0
    For Each URL In URLs
        URL.Offset(0, 2) = "Processing.."
        URL.Offset(0, 2).Interior.Color = 14922893
        strCommand = "CMD /C Ping -n 1 -w 300 " & URL & " | Findstr /B /C:" & Chr(34) & "Reply from" & Chr(34)
        Set objCommand = objShell.Exec(strCommand)
        strPingResult = objCommand.StdOut.ReadAll
        If strPingResult <> "" Then
            arrIPAddress = Split(strPingResult, ":")
            strIPAddress = Mid(arrIPAddress(0), 12)
            URL.Offset(0, 1).Value = strIPAddress
            URL.Offset(0, 2) = "Done"
            URL.Offset(0, 2).Interior.Color = 5296274
            URL.Offset(0, 1).Value = "NA"
            URL.Offset(0, 2) = "Failed"
            URL.Offset(0, 2).Interior.Color = 255
        End If
        i = i + 1
        If i >= 46 Then ActiveWindow.SmallScroll Down:=1
    MsgBox "Task Completed." & vbCrLf & i & " URLs processed", vbInformation, "Done"
    End Sub
    Private Sub CommandButton1_Click()
    End Sub

    Many thanks in advance.


    Monday, August 24, 2015 11:20 AM

All replies

  • I need to ping a port

    Have a look here:


    Monday, August 24, 2015 3:35 PM
  • Hi Bret,

    This is the forum to discuss questions and feedback for Microsoft Excel, I'll move your question to the MSDN forum for VBA. 

    The reason why we recommend posting appropriately is you will get the most qualified pool of respondents, and other partners who read the forums regularly can either share their knowledge or learn from your interaction with us. Thank you for your understanding.


    Emi Zhang
    TechNet Community Support

    It's recommended to download and install Configuration Analyzer Tool (OffCAT), which is developed by Microsoft Support teams. Once the tool is installed, you can run it at any time to scan for hundreds of known issues in Office programs. Please remember to mark the replies as answers if they help, and unmark the answers if they provide no help. If you have feedback for TechNet Support, contact

    Tuesday, August 25, 2015 2:20 AM
  • Hi Emi,

    Can we please clarify that this is the correct forum for Excel VBA queries? 72 views and no replies, what I am asking for I know is possible as I have another piece of VBA code that does it, but not as well as this one.

    I am just not a proficient coder to have the ability to pick bits out of one script and put them into another.



    Thursday, August 27, 2015 10:41 AM
  • You could try something like this:

    Function PingOK() As Boolean
      Dim objPing As Object
      Dim objItem As Object
      Dim done As Boolean
      Dim cnt As Integer
      done = False
      cnt = 1
      PingOK = False
      Do While Not done And cnt <= 4
        Set objPing = GetObject("winmgmts:{impersonationLevel=impersonate}"). _
                      ExecQuery("select * from Win32_PingStatus " & _
                      "where address = '" & "" & "'")
        cnt = cnt + 1
        For Each objItem In objPing
          If objItem.StatusCode = 0 Then
            PingOK = True
            done = True
          End If
        Next objItem
    End Function

    Thursday, August 27, 2015 2:35 PM