performance - Ping function makes the whole excel table slow/unresponsive -

i have function pings computers excel list , gets ping value of them.

while script running, excel unresponsive. fix doevents, made bit more responsive.

however, problem starts when function gets offline computer. while waits response of offline pc, excel freezes again , script not jump next pc until gets "timeout" actual one.

as default ping timeout value 4000ms, if have 100 computers in list, , 50 of them turned off, means have wait 3,3 minutes script finish, , blocks entire excel, making unusable duration.

my question is, if there way make faster or more responsive or smarter?

the actual code:

function:

function sping(shost) string      dim oping object, oretstatus object      set oping = getobject("winmgmts:{impersonationlevel=impersonate}").execquery _       ("select * win32_pingstatus address = '" & shost & "'")  doevents     each oretstatus in oping         doevents             if isnull(oretstatus.statuscode) or oretstatus.statuscode <> 0             sping = "timeout" 'oretstatus.statuscode <- error code         else             sping = sping & vbtab & oretstatus.responsetime         end if     next end function 

main:

sub pingall_click() dim c range dim p string dim actives string  actives = activesheet.name  stopcode = false  application.enablecancelkey = xlerrorhandler on error goto errh: doevents     each c in sheets(actives).usedrange.cells         if stopcode = true             exit         end if     doevents         if  left(c, 7) = "172.21."         p = sping(c)         [...]         end if     next c end sub 

as noted in comments, prevent blocking after each call, need invoke pings asynchronously function. way approach delegate sping(shost) function vbscript create on fly in temp folder. script this, , takes ip address command line argument , outputs result file:

dim args, ping, status set ping = getobject("winmgmts:{impersonationlevel=impersonate}").execquery _       ("select * win32_pingstatus address = '" & wscript.arguments(0) & "'") dim result each status in ping     if isnull(status.statuscode) or status.statuscode <> 0         result = "timeout"     else         result = result & vbtab & status.responsetime     end if next dim fso, file set fso = createobject("scripting.filesystemobject") set file = fso.createtextfile(wscript.arguments(0), true) file.write result file.close 

you can create sub write path this:

private sub writescript(path string)     dim handle integer     handle = freefile     open path & scriptname output #handle     print #handle, _         "dim args, ping, status" & vbcrlf & _         "set ping = getobject(""winmgmts:{impersonationlevel=impersonate}"").execquery _" & vbcrlf & _         "      (""select * win32_pingstatus address = '"" & wscript.arguments(0) & ""'"")" & vbcrlf & _         "dim result" & vbcrlf & _         "for each status in ping" & vbcrlf & _         "    if isnull(status.statuscode) or status.statuscode <> 0 then" & vbcrlf & _         "        result = ""timeout""" & vbcrlf & _         "    else" & vbcrlf & _         "        result = result & vbtab & status.responsetime" & vbcrlf & _         "    end if" & vbcrlf & _         "next" & vbcrlf & _         "dim fso, file" & vbcrlf & _         "set fso = createobject(""scripting.filesystemobject"")" & vbcrlf & _         "set file = fso.createtextfile(wscript.arguments(0), true)" & vbcrlf & _         "file.write result" & vbcrlf & _         "file.close"     close #handle end sub 

after that, it's pretty straightforward - create new directory in user's temp directory, plop script in there, , use shell command run each ping in own process. wait length of timeout, read results files:

private const tempdir = "\pingresults\" private const scriptname string = "ping.vbs" 'important - set time in seconds of ping timeout. private const timeout = 4  sub pingall_click()     dim sheet worksheet     set sheet = activesheet      dim path string     'create temp folder use.     path = environ("temp") & tempdir     mkdir path     'write script temp folder.     writescript path      dim results dictionary     set results = new dictionary      dim index long     dim ip variant     dim command string     index = 1 sheet.usedrange.rows.count         ip = sheet.cells(index, 1)         if len(ip) >= 7             if left$(ip, 1) = "172.21."                 'cache row in.                 results.add ip, index                 'shell script.                 command = "wscript " & path & "ping.vbs " & ip                 shell command, vbnormalfocus             end if         end if     next index      dim completed double     completed = timer + timeout     'wait timeout.     while timer < completed         doevents     loop      dim handle string, ping string, result string     'loop through resulting files , update sheet.     each ip in results.keys         result = dir$(path & ip)         if len(result) <> 0             handle = freefile             open path & ip input #handle             ping = input$(lof(handle), handle)             close #handle             kill path & ip         else             ping = "timeout"         end if         sheet.cells(results(ip), 2) = ping     next ip      'clean up.     kill path & "*"     rmdir path end sub 

note has 0 error handling file operations, , doesn't respond stopcode flag. should give basic gist of though. note if need allow user cancel it, won't able remove temp directory because still in use. if case, create if isn't there , don't remove when you're done.