AW: Immer die aktuelle Zelle anzeigen - markieren
05.08.2018 17:06:59
Werner
Hallo Albin,
gleiches wie oben bereits aber ohne die Selektiererei in deinem Code.
Sub ping()
Dim objWMIService As Object, i As Double
Dim colPings As Object, objPing As Object
On Error Resume Next
Range("B1:B300").ClearContents
With Range("B1:B300").Interior
.Pattern = xlNone
.TintAndShade = 0
.PatternTintAndShade = 0
End With
Set objWMIService = GetObject("winmgmts:{impersonationLevel=impersonate}!\\.\root\cimv2")
For i = 1 To Tabelle1.UsedRange.Rows.Count
If Cells(i, 1).Value "" Then
Application.StatusBar = Cells(i, 1).Value
Application.Goto Cells(i, 1), True
Set colPings = objWMIService.ExecQuery _
("Select * From Win32_PingStatus where Address = '" & Cells(i, 1).Text & "'")
If Err = 0 Then
Err.Clear
For Each objPing In colPings
If Err = 0 Then
Err.Clear
If objPing.StatusCode = 0 Then
Cells(i, 2).Value = "Timeout " & objPing.ResponseTime & " ms"
Cells(i, 2).Interior.ColorIndex = 4
Else
Cells(i, 2).Value = "nicht erreichbar"
Cells(i, 2).Interior.ColorIndex = 3
End If
End If
Next
Else
Err.Clear
End If
End If
Next
Application.StatusBar = False
End Sub
Gruß Werner