如何修改VBA代码仅将Excel最后一行数据同步至Access数据库

核心修改思路 #

• 原代码每次调用导入模块时会遍历第2行到最后一行的所有历史数据，导致重复堆积和卡顿。
• 通过在命令按钮事件中直接获取刚新增的行号，并将其作为参数传递给导入模块，让模块仅处理这一行数据，彻底解决重复问题。

修改后的代码 #

1. 命令按钮代码（修改后） #

Option Explicit
Private Sub CommandButton1_Click()
    Dim sh As Worksheet
    Set sh = ThisWorkbook.Sheets("Trial TRC")
    Dim newRow As Long
    newRow = sh.Range("A" & Application.Rows.Count).End(xlUp).Row + 1 '直接获取新增行的行号
    
    sh.Range("A" & newRow).Value = TextBox1.Value
    sh.Range("B" & newRow).Value = TextBox2.Value
    sh.Range("C" & newRow).Value = TextBox3.Value
    
    Call AddRecordsIntoAccessTable(newRow) '将新增行号传递给导入过程
End Sub

2. 模块代码（修改后） #

Option Explicit

'新增参数targetRow，指定仅导入这一行数据
Sub AddRecordsIntoAccessTable(targetRow As Long)
    Dim accessFile  As String
    Dim accessTable As String
    Dim sht         As Worksheet
    Dim lastColumn  As Integer
    Dim con         As Object
    Dim rs          As Object
    Dim sql         As String
    Dim j           As Integer
            
    Application.ScreenUpdating = False
    
    accessFile = ThisWorkbook.Path & "\" & "trialpower1.accdb"
         
    If FileExists(accessFile) = False Then
        MsgBox "The Access file doesn't exist!", vbCritical, "Invalid Access file path"
        Exit Sub
    End If
    
    accessTable = "Trial_TRC"
                
    On Error Resume Next
    Set sht = ThisWorkbook.Sheets("Trial TRC")
    If Err.Number <> 0 Then
        MsgBox "The given worksheet does not exist!", vbExclamation, "Invalid Sheet Name"
        Exit Sub
    End If
    Err.Clear
        
    With sht
        lastColumn = .Cells(1, .Columns.Count).End(xlToLeft).Column
    End With
    
    '校验要导入的行是否有效（至少为第2行，第1行是表头）
    If targetRow < 2 Or lastColumn < 1 Then
        MsgBox "No valid data to import!", vbCritical, "Empty Data"
        Exit Sub
    End If
        
    Set con = CreateObject("ADODB.connection")
    If Err.Number <> 0 Then
        MsgBox "The connection was not created!", vbCritical, "Connection Error"
        Exit Sub
    End If
    Err.Clear
    
    con.Open "Provider=Microsoft.ACE.OLEDB.12.0;Data Source=" & accessFile
    
    sql = "SELECT * FROM " & accessTable
    
    Set rs = CreateObject("ADODB.Recordset")
    If Err.Number <> 0 Then
        Set rs = Nothing
        Set con = Nothing
        MsgBox "The recordset was not created!", vbCritical, "Recordset Error"
        Exit Sub
    End If
    Err.Clear
             
    rs.CursorType = 1   'adOpenKeyset on early binding
    rs.LockType = 3     'adLockOptimistic on early binding
        
    rs.Open sql, con
    
    '仅处理指定的targetRow单行数据
    rs.AddNew
    For j = 1 To lastColumn
        rs(sht.Cells(1, j).Value) = sht.Cells(targetRow, j).Value
    Next j
    rs.Update
        
    rs.Close
    con.Close
    
    Set rs = Nothing
    Set con = Nothing
    
    Application.ScreenUpdating = True

    MsgBox "1 row was successfully added into the '" & accessTable & "' table!", vbInformation, "Done"
    
End Sub

Function FileExists(FilePath As String) As Boolean
    On Error Resume Next
    If Len(FilePath) > 0 Then
        If Not Dir(FilePath, vbDirectory) = vbNullString Then FileExists = True
    End If
    On Error GoTo 0
End Function

关键修改点说明 #

• 命令按钮部分：直接计算新增行的行号，避免模块重复扫描所有历史数据，同时精准传递导入目标。
• 模块部分：
  • 新增targetRow参数，锁定仅导入指定行。
  • 删除了遍历所有行的循环，改为仅处理单行，大幅提升运行速度。
  • 新增行有效性校验，避免无效导入操作。
  • 更新提示信息，明确告知用户导入行数。

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