如何修改Excel VBA IP监控脚本，实现单行多IP依次Ping并逐行执行（单按钮）

我用VBA在Excel里搭建了IP监控工具，主IP存储在J列，第一台故障转移IP（Failover IP）在M列，第二台故障转移IP在P列。目前可单独触发各列的Ping脚本，现需修改脚本实现：按行从左到右依次Ping该行的主IP、故障转移IP，完成后下移一行重复该操作，且仅通过一个按钮触发执行。

现有脚本如下：

Sub Ping()
    
    Sheet1.Range("K8:K952").Clear
    Dim hostIp1 As String
    For i = 8 To Cells(Rows.Count, 1).End(xlUp).Row
    
            
    hostIp1 = Sheet1.Cells(i, 10).Value
    If Not hostIp1 = "" Then
    Dim objShell1, returnCode1
    
    Set objShell1 = CreateObject("wscript.shell")
            returnCode1 = objShell1.Run("Ping -n 1 -w 1000 " & hostIp1, 0, True)
    
    If returnCode1 = 0 Then
                Sheet1.Cells(i, 11).Value = "Online"
                Sheet1.Cells(i, 11).Font.Color = vbGreen
                Sheet1.Cells(i, 12).Value = Now
            Else
                Sheet1.Cells(i, 11).Value = "Offline"
                Sheet1.Cells(i, 11).Font.Color = vbRed
    End If
    End If
    Next

End Sub

Sub Ping2()

    Sheet1.Range("N8:N952").Clear
    Dim hostIp2 As String
    For j = 8 To Cells(Rows.Count, 1).End(xlUp).Row
    
            
    hostIp2 = Sheet1.Cells(j, 13).Value
    If Not hostIp2 = "" Then
    Dim objShell2, returnCode2
    
    Set objShell2 = CreateObject("wscript.shell")
            returnCode2 = objShell2.Run("Ping -n 1 -w 1000 " & hostIp2, 0, True)
    
    If returnCode2 = 0 Then
                Sheet1.Cells(j, 14).Value = "Online"
                Sheet1.Cells(j, 14).Font.Color = vbGreen
                Sheet1.Cells(j, 15).Value = Now
        
            Else
                Sheet1.Cells(j, 14).Value = "Offline"
                Sheet1.Cells(j, 14).Font.Color = vbRed
                
    End If
    End If

Next

End Sub

Sub Ping3()

    Sheet1.Range("Q8:Q952").Clear
    Dim hostIp3 As String
    For k = 8 To Cells(Rows.Count, 1).End(xlUp).Row
        
        
    hostIp3 = Sheet1.Cells(k, 16).Value
    If Not hostIp3 = "" Then
    Dim objShell3, returnCode3
            
    Set objShell3 = CreateObject("wscript.shell")
            returnCode3 = objShell3.Run("Ping -n 1 -w 1000 " & hostIp3, 0, True)
            
            
    If returnCode3 = 0 Then
                Sheet1.Cells(k, 17).Value = "Online"
                Sheet1.Cells(k, 17).Font.Color = vbGreen
                Sheet1.Cells(k, 18).Value = Now
    
            Else
                Sheet1.Cells(k, 17).Value = "Offline"
                Sheet1.Cells(k, 17).Font.Color = vbRed
            End If
            End If

        Next

End Sub

解决方案 #

将三个独立的Ping逻辑整合到一个Sub中，按行循环处理每行的三个IP，实现按行顺序Ping的需求。优化后的代码如下：

Sub PingAllByRow()
    ' 清空所有状态列的内容
    Sheet1.Range("K8:K952").Clear
    Sheet1.Range("N8:N952").Clear
    Sheet1.Range("Q8:Q952").Clear
    
    Dim lastRow As Long
    lastRow = Sheet1.Cells(Rows.Count, 1).End(xlUp).Row
    
    Dim objShell As Object
    Set objShell = CreateObject("wscript.shell")
    
    Dim i As Long
    Dim hostIp As String
    Dim returnCode As Integer
    
    ' 按行循环处理
    For i = 8 To lastRow
        ' 1. Ping主IP（J列，列号10），结果写入K列（11），时间写入L列（12）
        hostIp = Sheet1.Cells(i, 10).Value
        If hostIp <> "" Then
            returnCode = objShell.Run("Ping -n 1 -w 1000 " & hostIp, 0, True)
            If returnCode = 0 Then
                Sheet1.Cells(i, 11).Value = "Online"
                Sheet1.Cells(i, 11).Font.Color = vbGreen
                Sheet1.Cells(i, 12).Value = Now
            Else
                Sheet1.Cells(i, 11).Value = "Offline"
                Sheet1.Cells(i, 11).Font.Color = vbRed
            End If
        End If
        
        ' 2. Ping第一台故障转移IP（M列，列号13），结果写入N列（14），时间写入O列（15）
        hostIp = Sheet1.Cells(i, 13).Value
        If hostIp <> "" Then
            returnCode = objShell.Run("Ping -n 1 -w 1000 " & hostIp, 0, True)
            If returnCode = 0 Then
                Sheet1.Cells(i, 14).Value = "Online"
                Sheet1.Cells(i, 14).Font.Color = vbGreen
                Sheet1.Cells(i, 15).Value = Now
            Else
                Sheet1.Cells(i, 14).Value = "Offline"
                Sheet1.Cells(i, 14).Font.Color = vbRed
            End If
        End If
        
        ' 3. Ping第二台故障转移IP（P列，列号16），结果写入Q列（17），时间写入R列（18）
        hostIp = Sheet1.Cells(i, 16).Value
        If hostIp <> "" Then
            returnCode = objShell.Run("Ping -n 1 -w 1000 " & hostIp, 0, True)
            If returnCode = 0 Then
                Sheet1.Cells(i, 17).Value = "Online"
                Sheet1.Cells(i, 17).Font.Color = vbGreen
                Sheet1.Cells(i, 18).Value = Now
            Else
                Sheet1.Cells(i, 17).Value = "Offline"
                Sheet1.Cells(i, 17).Font.Color = vbRed
            End If
        End If
    Next i
    
    Set objShell = Nothing
End Sub

代码说明 #

• 提前获取最后一行行号，避免重复计算，提升效率
• 只创建一次wscript.shell对象，减少资源消耗
• 按行顺序依次处理每行的三个IP，满足"先处理完当前行所有IP再下移"的需求
• 保留原脚本的状态标记、颜色设置和时间戳功能
• 将该Sub绑定到Excel按钮上，即可一键触发所有IP的按行Ping操作

内容的提问来源于stack exchange，提问作者Chris