如何排除Excel无效输入并避免其传入SQL数据库？

问题分析 #

你碰到的Object Variable or with block variable not set错误，多是因为查询无匹配记录时，部分数据库驱动返回Nothing而非空Recordset，导致后续访问rsPD.EOF触发异常。同时原代码未处理无记录场景，也未标记无效值。

修改后的代码 #

Private Sub CommandButton1_Click()
    Dim StartTime As Double
    Dim SecondsElapsed As Double
    Dim vault As String
    Dim prtlst As ListObject
    Dim connPD As ADODB.Connection
    Dim rsPD As ADODB.Recordset
    Dim PDConnString As String
    Dim SelStringPD As String
    Dim cLocalPath As String
    Dim rowCnt As Long
    Dim PLoc As Range
    Dim currentInput As String
    
    ' 替换为实际连接信息
    PDConnString = "Provider=YourProvider;Data Source=YourDataSource;" & _
                  "User ID=YourUserID;Password=YourPassword;"
    
    Set prtlst = ThisWorkbook.Worksheets("Sheet1").ListObjects("Table1")
    
    Set connPD = New ADODB.Connection
    ' 初始化Recordset为Nothing，避免残留引用
    Set rsPD = Nothing
    
    On Error GoTo GlobalErrorHandler
    
    connPD.Open PDConnString
    connPD.CursorLocation = adUseClient
    
    Application.ScreenUpdating = False
    Application.Calculation = xlCalculationManual
    
    Set PLoc = prtlst.Range(2, 1)
    rowCnt = 0
    
    Do While Not IsEmpty(PLoc.Offset(rowCnt, 0).Value)
        currentInput = PLoc.Offset(rowCnt, 0).Value
        ' 默认清除之前的格式
        PLoc.Offset(rowCnt, 0).Font.ColorIndex = xlAutomatic
        
        ' 循环内添加局部错误捕获，单个查询失败不终止整个程序
        On Error Resume Next
        SelStringPD = "SELECT * FROM YourTable WHERE ValueText = '" & Replace(currentInput, "'", "''") & "';"
        Set rsPD = connPD.Execute(SelStringPD)
        ' 捕获当前查询的错误
        If Err.Number <> 0 Then
            PLoc.Offset(rowCnt, 0).Font.Color = vbRed
            Err.Clear
            rowCnt = rowCnt + 1
            ' 重置错误处理为全局
            On Error GoTo GlobalErrorHandler
            Continue Do
        End If
        On Error GoTo GlobalErrorHandler
        
        ' 检查Recordset是否有效且有数据
        If Not rsPD Is Nothing And Not rsPD.EOF Then
            PLoc.Offset(rowCnt, 1).Value = rsPD.Fields("FileName").Value
            PLoc.Offset(rowCnt, 2).Value = rsPD.Fields("Path").Value
            PLoc.Offset(rowCnt, 3).Value = rsPD.Fields("LatestRevisionNo").Value
            PLoc.Offset(rowCnt, 4).Value = ThisWorkbook.Worksheets("Sheet1").Range("VAULTPATH").Value & rsPD.Fields("Path").Value & rsPD.Fields("FileName").Value
        Else
            ' 无匹配记录，标记红色
            PLoc.Offset(rowCnt, 0).Font.Color = vbRed
        End If
        
        ' 关闭当前Recordset，释放资源
        If Not rsPD Is Nothing Then
            If rsPD.State = adStateOpen Then rsPD.Close
            Set rsPD = Nothing
        End If
        
        rowCnt = rowCnt + 1
    Loop
    
CleanExit:
    Application.ScreenUpdating = True
    Application.Calculation = xlCalculationAutomatic
    
    ' 清理资源
    If Not rsPD Is Nothing Then
        If rsPD.State = adStateOpen Then rsPD.Close
        Set rsPD = Nothing
    End If
    
    If Not connPD Is Nothing Then
        If connPD.State = adStateOpen Then connPD.Close
        Set connPD = Nothing
    End If
    
    Exit Sub

GlobalErrorHandler:
    MsgBox "全局错误: " & Err.Description, vbExclamation
    Resume CleanExit
End Sub

关键修改点 #

• 循环内局部错误捕获：用On Error Resume Next捕获单条查询的异常，避免因某条无效数据中断整个程序，处理后重置为全局错误处理逻辑
• SQL注入防护：通过Replace(currentInput, "'", "''")转义输入中的单引号，避免SQL语法错误和注入风险
• 无效值标记：查询无结果或出错时，将当前输入单元格字体设为红色
• Recordset资源管理：每次循环后关闭并释放rsPD，避免残留引用引发对象未设置错误
• 格式重置：处理前清除单元格原有格式，避免重复运行时格式混乱

额外优化建议 #

• 改用参数化查询替代字符串拼接，进一步提升安全性和稳定性，示例：

  SelStringPD = "SELECT * FROM YourTable WHERE ValueText = ?;"
  Dim cmd As ADODB.Command
  Set cmd = New ADODB.Command
  cmd.ActiveConnection = connPD
  cmd.CommandText = SelStringPD
  cmd.Parameters.Append cmd.CreateParameter("InputVal", adVarChar, adParamInput, 255, currentInput)
  Set rsPD = cmd.Execute
  

• 批量读取输入数据到数组后再处理，提升大数据集下的运行效率

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