请求修改VBA导出代码：实现ID校验与未导入数据标记

我完全理解你的需求——要让代码能逐行处理数据，成功导入Access的正常完成，遇到重复ID这类导入失败的情况时，自动给该行做标记，不中断整个批量处理流程。下面是调整后的代码，先讲关键修改点，再放完整代码：

核心修改说明： #

• 把On Error Resume Next放到行循环内部，这样单条数据导入失败时不会终止整个程序，而是捕获错误后继续处理下一行
• 新增错误检查逻辑：如果导入触发错误（比如ID重复违反主键约束），就把该行字体标红，在H列新增“Not Imported”标注
• 添加了成功/失败条目统计，最后给用户清晰的结果反馈
• 保留原有的核心导入逻辑，仅增强错误处理和标记功能

完整代码： #

Sub Export_Data()
    Dim cnn As ADODB.Connection
    Dim rst As ADODB.Recordset
    Dim dbPath As String
    Dim x As Long, i As Long
    Dim nextrow As Long
    Dim successCount As Long, failCount As Long ' 统计成功/失败数量
    
    ' 初始化统计变量
    successCount = 0
    failCount = 0
    
    ' 检查数据库路径有效性
    dbPath = ActiveSheet.Range("I3").Value
    If Dir(dbPath) = "" Then
        MsgBox "数据库路径无效，请检查I3单元格的配置！", vbExclamation
        Exit Sub
    End If
    
    ' 检查是否有可导入的数据
    nextrow = Cells(Rows.Count, 1).End(xlUp).Row
    If nextrow < 2 Then
        MsgBox "请先添加要导入到Access的数据！", vbExclamation
        Exit Sub
    End If
    
    ' 初始化数据库连接和记录集
    On Error GoTo errHandler:
    Set cnn = New ADODB.Connection
    cnn.Open "Provider=Microsoft.ACE.OLEDB.12.0;Data Source=" & dbPath
    
    Set rst = New ADODB.Recordset
    rst.Open Source:="PhoneList", ActiveConnection:=cnn, _
             CursorType:=adOpenDynamic, LockType:=adLockOptimistic, _
             Options:=adCmdTable
    
    ' 关闭屏幕更新，提升批量处理速度
    Application.ScreenUpdating = False
    
    ' 循环处理每一行数据
    For x = 2 To nextrow
        ' 重置错误状态
        Err.Clear
        On Error Resume Next ' 临时开启单条数据的错误捕获
        
        ' 尝试添加当前行到Access
        rst.AddNew
        For i = 1 To 7
            rst(Cells(1, i).Value) = Cells(x, i).Value
        Next i
        rst.Update
        
        ' 检查是否有错误发生
        If Err.Number <> 0 Then
            ' 标记失败条目：字体变红，H列添加标注
            Cells(x, 1).Resize(1, 7).Font.Color = vbRed
            Cells(x, 8).Value = "Not Imported"
            failCount = failCount + 1
        Else
            successCount = successCount + 1
        End If
        
        On Error GoTo errHandler ' 恢复全局错误处理逻辑
    Next x
    
    ' 清理数据库资源
    rst.Close
    cnn.Close
    Set rst = Nothing
    Set cnn = Nothing
    
    ' 恢复屏幕更新并提示结果
    Application.ScreenUpdating = True
    MsgBox "导入任务完成！" & vbCrLf & "成功导入：" & successCount & "条" & vbCrLf & "未导入：" & failCount & "条", vbInformation
    
    Exit Sub
    
errHandler:
    ' 全局错误处理
    MsgBox "Error " & Err.Number & " (" & Err.Description & ") in procedure Export_Data", vbCritical
    ' 确保资源被正确清理
    If Not rst Is Nothing Then rst.Close
    If Not cnn Is Nothing Then cnn.Close
    Set rst = Nothing
    Set cnn = Nothing
    Application.ScreenUpdating = True
End Sub

额外提示： #

• 如果你的表格已经用到H列，可以把Cells(x, 8)改成其他空白列的序号（比如第9列就写Cells(x, 9)）
• 新增的数据库路径检查，能提前避免因路径无效导致的全局报错
• 关闭屏幕更新后，批量处理大量数据时运行速度会明显提升

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