为何Excel VBA的Do Until循环仅提交最后一条表单数据？如何实现逐条写入数据库工作表

阿华AIGC实验室

2026-4-28

问题分析与修正方案

嘿，我一眼就看出问题所在了——你的循环里完全没让数据库的目标行号递增！

你在循环开始前只计算了一次TaskCurrentRow（也就是数据库工作表的下一个空行），但整个循环过程中这个变量一直保持不变。所以每一次循环都把新数据写到同一个行号上，后面的条目直接覆盖了前面的，最后自然就只剩最后一条数据啦。

修正后的代码（保留你的原有结构）

只需要在循环内部每次写完数据后，让TaskCurrentRow加1就行：

'Begin code for Task Recording'
Dim shTaskDB As Worksheet
Dim shPMPlan As Worksheet ' 补充定义表单工作表，你之前的代码里漏了这个！
Set shTaskDB = ThisWorkbook.Sheets("Task DB")
Set shPMPlan = ThisWorkbook.Sheets("你的表单工作表名称") ' 替换成实际的表单工作表名

Dim TaskCurrentRow As Integer
TaskCurrentRow = shTaskDB.Range("A" & Application.Rows.Count).End(xlUp).Row + 1

With shTaskDB
    shPMPlan.Range("L4").Select
    ' Set Do loop to stop when an empty cell is reached.
    Do Until ActiveCell = ""
        .Cells(TaskCurrentRow, 1) = shPMPlan.Range("C4")
        .Cells(TaskCurrentRow, 2) = shPMPlan.Cells(ActiveCell.Row, "K")
        .Cells(TaskCurrentRow, 3) = shPMPlan.Cells(ActiveCell.Row, "L")
        .Cells(TaskCurrentRow, 4) = shPMPlan.Cells(ActiveCell.Row, "M")
        .Cells(TaskCurrentRow, 5) = shPMPlan.Cells(ActiveCell.Row, "N")
        .Cells(TaskCurrentRow, 6) = shPMPlan.Cells(ActiveCell.Row, "O")
        .Cells(TaskCurrentRow, 7) = shPMPlan.Cells(ActiveCell.Row, "P")
        
        ' 关键修改：写完一行后，让数据库目标行号加1
        TaskCurrentRow = TaskCurrentRow + 1
        
        ActiveCell.Offset(1, 0).Select
    Loop
End With
MsgBox "Project Plan Recorded"

更推荐的优化版本（避免使用Select/ActiveCell）

在VBA里用Select和ActiveCell很容易出问题（比如用户不小心点击了其他单元格，代码就跑飞了），而且效率不高。推荐用变量直接跟踪表单的行号：

'Begin code for Task Recording'
Dim shTaskDB As Worksheet
Dim shPMPlan As Worksheet
Set shTaskDB = ThisWorkbook.Sheets("Task DB")
Set shPMPlan = ThisWorkbook.Sheets("你的表单工作表名称")

Dim TaskCurrentRow As Integer
Dim formRow As Integer ' 跟踪表单当前处理的行

TaskCurrentRow = shTaskDB.Range("A" & Application.Rows.Count).End(xlUp).Row + 1
formRow = 4 ' 表单起始行是第4行

With shTaskDB
    ' 循环直到表单L列对应行为空
    Do Until shPMPlan.Cells(formRow, "L") = ""
        .Cells(TaskCurrentRow, 1) = shPMPlan.Range("C4")
        .Cells(TaskCurrentRow, 2) = shPMPlan.Cells(formRow, "K")
        .Cells(TaskCurrentRow, 3) = shPMPlan.Cells(formRow, "L")
        .Cells(TaskCurrentRow, 4) = shPMPlan.Cells(formRow, "M")
        .Cells(TaskCurrentRow, 5) = shPMPlan.Cells(formRow, "N")
        .Cells(TaskCurrentRow, 6) = shPMPlan.Cells(formRow, "O")
        .Cells(TaskCurrentRow, 7) = shPMPlan.Cells(formRow, "P")
        
        ' 同时递增两个行号
        TaskCurrentRow = TaskCurrentRow + 1
        formRow = formRow + 1
    Loop
End With
MsgBox "Project Plan Recorded"