ARTICLE · 1091473
Excel VBA一键按条件追加写入指定工作簿(自动新增行,不覆盖原有数据)
Excel VBA一键按条件追加写入指定工作簿(自动新增行,不覆盖原有数据)功能说明 1. 弹窗选择目标工作簿（固定存放汇总数据的文件） 2. 读取当前工作表的录入区域数据 3. 条件校验：满足条件才追加写入；不满足直接提示，不保存 4. 自动定位目标表最后一行，新增一行追加，原有数据不会被覆盖 5. 支持打开/关闭目标文件，写完自动保存，不干扰用户操作 6. 增加成功/失败弹窗提示，错误捕获，防止程序崩溃 场景：表单录入、台账登记，每次填写完点按钮，自动追加到汇总表，带校验规则。 📌 代码（可直接复制） vba Sub AddDataToTargetWorkbook() Dim wbSource As Workbook, wsSource As Worksheet Dim wbTarget As Workbook, wsTarget As Worksheet Dim fd As FileDialog Dim strFile As String Dim lastRow As Long, i As Long '===== 可自行修改参数区 ===== Const CheckCol As Integer = 1 '条件判断列：A列 Const DataStartCol As Integer = 1 '数据开始列 Const DataEndCol As Integer = 5 '数据结束列（A-E列写入） Const TargetSheetName As String = "汇总" '目标工作表名称 '=========================== Set wbSource = ThisWorkbook Set wsSource = wbSource.ActiveSheet '【1】选择目标汇总文件 Set fd = Application.FileDialog(msoFileDialogFilePicker) With fd .Title = "选择要追加数据的目标汇总文件" .Filters.Clear .Filters.Add "Excel文件", "*.xls;*.xlsx;*.xlsm" If .Show <> -1 Then MsgBox "未选择文件，退出", vbInformation Set fd = Nothing Exit Sub End If strFile = .SelectedItems(1) End With Set fd = Nothing '【2】条件判断示例：A2不为空才允许录入，可按需修改这个判断 If Trim(wsSource.Range("A2").Value) = "" Then MsgBox "校验不通过！条件字段不能为空，无法录入", vbExclamation Exit Sub End If '【3】打开目标文件（后台打开，不弹窗闪烁） Application.ScreenUpdating = False On Error GoTo ErrHandle Set wbTarget = Workbooks.Open(strFile) Set wsTarget = wbTarget.Worksheets(TargetSheetName) '【4】找到目标表最后一行，向下追加 lastRow = wsTarget.Cells(wsTarget.Rows.Count, DataStartCol).End(xlUp).Row + 1 '【5】数组写入（不使用Copy，速度更快） Dim arrData As Variant arrData = wsSource.Range(wsSource.Cells(2, DataStartCol), wsSource.Cells(2, DataEndCol)).Value wsTarget.Cells(lastRow, DataStartCol).Resize(1, UBound(arrData, 2)).Value = arrData '【6】保存关闭目标文件 wbTarget.Save wbTarget.Close SaveChanges:=False Application.ScreenUpdating = True MsgBox "✅数据追加成功！已写入汇总表第" & lastRow & "行", vbInformation Exit Sub ErrHandle: Application.ScreenUpdating = True MsgBox "❌出错：" & Err.Description, vbCritical If Not wbTarget Is Nothing Then wbTarget.Close SaveChanges:=False End If End Sub 核心特点 ✅ 追加写入，不会覆盖原有数据，每次自动找最后一行+1新增 ✅ 数组传输，不用Copy方法，大数据也流畅 ✅ 带条件校验，不满足条件直接终止，防止脏数据进台账 ✅ 错误捕获：目标文件被占用、工作表不存在时弹出提示，不会卡死Excel ✅ 自动保存目标文件，写完自动关闭 ⚠️ 避坑提醒 1. 目标文件不要打开！代码会后台打开，如果手动占用会报错 2. 如果目标文件是xlsm宏文件，同样支持； 3. 条件规则自由改：可以判断日期、数值范围、文本内容； 💡拓展预告 专业定制VBA开发，如果需要批量多行追加（当前表多行一次性写入汇总），关注留言告诉我，我给你升级多行版本。 VBA一键按条件自动提取数据（文员、生产统计专用） VBA一键对比两个Excel文件｜自动识别相同-差异数据，不同单元格填充颜色 Excel VBA神器～一键百万级数据不卡顿，列名自动匹配-高速合并自动增加文件名 一键导入外部Excel！VBA文件选择器，自动提取数据到当前表