ARTICLE · 1145729
Excel VBA一键台账归档,保留最新记录,旧数据自动移入历史归档表
Excel VBA一键台账归档,保留最新记录,旧数据自动移入历史归档表场景说明 很多做库存台账、每日业务记录、设备台账的朋友会遇到： 同一个编号（A列主键）有多条多次录入记录，只需要在主台账保留最新一条记录，更早的记录不能删除，全部移到【历史归档】工作表存放。 ✅ 功能特点 1. 数组版，大数据量不卡顿，不用单元格Copy，速度快 2. 以A列为唯一匹配主键（物料编号/订单号） 3. 主表【台账】：每个编号仅保留时间最新一行 4. 旧记录自动剪切到【历史归档】，不会丢失数据 5. 自动判断工作表是否存在，不存在就新建 6. 自带表头，归档表自动延续原有表头 7. 增加【归档时间】列，标记这条数据什么时候被归档 示例数据预览（公众号配图文字说明，你可以直接做成表格截图） 【台账】原始数据 
运行宏之后： 台账表只保留最新：001（9.10）、002（9.08） 历史归档表存入：001（9.01），附带归档时间 VBA完整代码可直接复制 vba Sub 台账自动归档_保留最新记录() Dim wsMain As Worksheet, wsArchive As Worksheet Dim arrData, arrNew, arrOld Dim dict As Object Dim lastRow As Long, lastCol As Long Dim i As Long, kNew As Long, kOld As Long Dim keyID As String, updateDate As Date Dim flag As Boolean '关闭屏幕刷新，提速 Application.ScreenUpdating = False Application.EnableEvents = False On Error GoTo ErrHandle '绑定主表【台账】 Set wsMain = ThisWorkbook.Worksheets("台账") '判断归档表是否存在，不存在新建 flag = False For Each ws In ThisWorkbook.Worksheets If ws.Name = "历史归档" Then Set wsArchive = ws flag = True Exit For End If Next ws If flag = False Then Set wsArchive = ThisWorkbook.Worksheets.Add(After:=wsMain) wsArchive.Name = "历史归档" '复制表头 wsMain.Rows(1).Copy wsArchive.Range("A1") wsArchive.Range(wsArchive.Cells(1, wsMain.Columns.Count + 1)).Value = "归档时间" End If '读取台账全部数据到数组 lastRow = wsMain.Cells(wsMain.Rows.Count, "A").End(xlUp).Row lastCol = wsMain.Cells(1, wsMain.Columns.Count).End(xlToLeft).Column If lastRow < 2 Then MsgBox "台账没有可处理的数据！", vbInformation GoTo EndSub End If arrData = wsMain.Range(wsMain.Cells(1, 1), wsMain.Cells(lastRow, lastCol)).Value '字典：key=编号，存储最新行信息 Set dict = CreateObject("Scripting.Dictionary") dict.CompareMode = vbTextCompare '第一轮遍历：找出每个编号的最新记录 For i = 2 To UBound(arrData) keyID = Trim(arrData(i, 1)) If keyID <> "" Then updateDate = CDate(arrData(i, 4)) 'D列为更新时间列，可自行修改 If Not dict.Exists(keyID) Then dict(keyID) = Array(i, updateDate) Else If updateDate > dict(keyID)(1) Then dict(keyID) = Array(i, updateDate) End If End If End If Next i '第二轮拆分：最新记录放进arrNew，旧记录放进arrOld ReDim arrNew(1 To dict.Count + 1, 1 To lastCol) ReDim arrOld(1 To UBound(arrData), 1 To lastCol) '表头写入 For i = 1 To lastCol arrNew(1, i) = arrData(1, i) Next i kNew = 1 kOld = 0 For i = 2 To UBound(arrData) keyID = Trim(arrData(i, 1)) If keyID <> "" Then '判断当前行是否是该编号最新行 If dict(keyID)(0) = i Then kNew = kNew + 1 For j = 1 To lastCol arrNew(kNew, j) = arrData(i, j) Next j Else kOld = kOld + 1 For j = 1 To lastCol arrOld(kOld, j) = arrData(i, j) Next j End If End If Next i '回写主台账表（只保留最新） wsMain.Range(wsMain.Cells(1, 1), wsMain.Cells(lastRow, lastCol)).ClearContents wsMain.Range("A1").Resize(kNew, lastCol).Value = arrNew '旧数据追加到历史归档表，附带归档时间 If kOld > 0 Then Dim archLastRow As Long archLastRow = wsArchive.Cells(wsArchive.Rows.Count, "A").End(xlUp).Row + 1 wsArchive.Range("A" & archLastRow).Resize(kOld, lastCol).Value = arrOld wsArchive.Cells(archLastRow, lastCol + 1).Resize(kOld, 1).Value = Now() End If MsgBox "归档完成！" & vbCrLf & "台账保留最新记录：" & kNew - 1 & "条" & vbCrLf & "本次归档旧数据：" & kOld & "条", vbInformation EndSub: Application.ScreenUpdating = True Application.EnableEvents = True Set dict = Nothing Exit Sub ErrHandle: MsgBox "出错：" & Err.Description, vbCritical Resume EndSub End Sub ⚙️ 参数修改说明 1. 主键列：A列：用A列编号判断是不是同一条台账，不用改。如果你的编号在B列，把代码里所有 arrData(i,1) 改成 arrData(i,2) 2. 时间列：D列：代码默认D列是更新日期，用来判断哪一条是最新。你的日期在C列，修改 arrData(i,4) → arrData(i,3) 3. 工作表名称：主表固定叫【台账】，归档表【历史归档】，名字不一样需要修改代码对应位置 4. 归档自动新增一列：归档时间，记录什么时候移入归档，方便追溯 📝 如果有需要追加功能：支持手动设置保留N条最新记录（比如保留最近3条，其余归档）可以关注我私信留言。 VBA专业开发，每日分享实用小技巧，关注我不迷路。 VBA一键按条件自动提取数据（文员、生产统计专用） VBA一键拆分工作表！按列自动分Sheet/分独立文件，十万行数据不卡顿 Excel VBA｜多个文件，批量合并数据导入到当前表 Excel VBA 双向台账：按A列匹配，有则更新、无则新增（数组高速版） VBA一键对比两个Excel文件｜自动识别相同-差异数据，不同单元格填充颜色