Excel按指定Item ID筛选最早N条记录跨表迁移并删除的方法

无编程基础的情况下，优先使用零代码操作方案，高频使用场景可配置一键脚本，两种方案均可100%满足需求。

方案一：零代码内置功能实现（适合每月提取次数少于5次的场景，无需编写代码） #

提前给原始表加1列辅助列做排序标记，全程用Excel自带筛选功能即可完成操作：

• 前置准备：在原始数据表最右侧插入新列，列名设置为「同ID排序号」。假设表内Item ID在A列、关联日期在C列，第一行是表头、数据从第2行开始，就在新列的第2行（即D2单元格）输入公式：=COUNTIFS(A:A,A2,C:C,"<"&C2)+COUNTIFS(A$2:A2,A2,C$2:C2,C2)，按回车后把公式下拉填充到所有数据行。这个公式会自动给同一个Item ID下的所有行，按日期从早到晚依次标注1、2、3……的序号，日期最早的行序号最小，同日期的行按原表顺序编号。
• 提取操作步骤：
  1. 选中原始表全量数据区域，点击顶部「数据」选项卡的「筛选」按钮，给所有列添加筛选箭头
  2. 点击Item ID列的筛选箭头，仅勾选需要提取的目标Item ID，点击确定
  3. 点击「同ID排序号」列的筛选箭头，选择「数字筛选-小于或等于」，输入需要提取的单位数量，点击确定
  4. 此时筛选出的所有可见行，就是对应Item ID下日期最早的指定数量记录，选中这些行按Ctrl+C复制，新建空白工作表按Ctrl+V粘贴即可
• 原表清理操作：保持当前筛选状态不变，选中所有可见行，右键选择「删除行」，再点击任意列的筛选箭头选择「清除筛选」，剩下的就是未提取的有效原始数据。

注意：后续原始表新增数据时，只要把辅助列的公式下拉填充到新行即可，无需调整公式逻辑。

方案二：VBA一键脚本实现（适合每周多次提取的场景，一次配置永久使用） #

如果需要高频操作，配置一次宏脚本后，只需输入两个参数即可自动完成全流程操作：

• 配置步骤：
  1. 打开目标Excel文件，按Alt+F11调出VBA编辑器，在左侧工程资源栏右键点击当前工作簿名称，选择「插入-模块」
  2. 将下方代码粘贴到右侧弹出的空白代码编辑窗口

Sub 提取指定单位记录()
    Dim targetID As String, extractNum As Long
    Dim lastRow As Long, i As Long, cnt As Long, pasteRow As Long
    Dim wsSource As Worksheet, wsTarget As Worksheet
    Dim delRng As Range
    ' 弹窗获取输入参数
    targetID = InputBox("请输入要提取的Item ID：")
    If targetID = "" Then Exit Sub
    extractNum = Val(InputBox("请输入要提取的单位数量："))
    If extractNum <= 0 Then Exit Sub
    ' 绑定原始数据表，若原始表名不是"原始数据"，修改引号内的表名即可
    Set wsSource = ThisWorkbook.Worksheets("原始数据")
    ' 新建存储提取结果的工作表
    Application.DisplayAlerts = False
    On Error Resume Next
    ThisWorkbook.Worksheets("提取结果_" & targetID & "_" & Format(Now(), "YYYYMMDDHHMM")).Delete
    On Error GoTo 0
    Application.DisplayAlerts = True
    Set wsTarget = ThisWorkbook.Worksheets.Add(After:=wsSource)
    wsTarget.Name = "提取结果_" & targetID & "_" & Format(Now(), "YYYYMMDDHHMM")
    ' 复制表头
    wsSource.Rows(1).Copy wsTarget.Rows(1)
    pasteRow = 2
    lastRow = wsSource.Cells(wsSource.Rows.Count, "A").End(xlUp).Row
    ' 关闭屏幕刷新提升运行速度
    Application.ScreenUpdating = False
    ' 按日期升序排序同Item ID的记录
    wsSource.Sort.SortFields.Clear
    wsSource.Sort.SortFields.Add Key:=wsSource.Range("C:C"), SortOn:=xlSortOnValues, Order:=xlAscending
    With wsSource.Sort
        ' 如果表格不止4列，把下面的D改成表格最后一列的列标即可
        .SetRange wsSource.Range("A1:D" & lastRow)
        .Header = xlYes
        .MatchCase = False
        .Apply
    End With
    ' 遍历提取指定数量记录，标记待删除行
    cnt = 0
    For i = 2 To lastRow
        If wsSource.Cells(i, "A").Value = targetID Then
            cnt = cnt + 1
            If cnt <= extractNum Then
                wsSource.Rows(i).Copy wsTarget.Rows(pasteRow)
                pasteRow = pasteRow + 1
                If delRng Is Nothing Then
                    Set delRng = wsSource.Rows(i)
                Else
                    Set delRng = Union(delRng, wsSource.Rows(i))
                End If
            Else
                Exit For
            End If
        End If
    Next i
    ' 删除原表已提取记录
    If Not delRng Is Nothing Then delRng.Delete
    Application.ScreenUpdating = True
    MsgBox "操作完成，共提取" & cnt & "条记录，结果已存入新工作表"
End Sub

3. 回到Excel界面按Alt+F8，选中「提取指定单位记录」宏，点击「选项」设置一个顺手的快捷键（比如Ctrl+Q），保存即可。

• 使用方式：后续需要提取数据时，只要按下设置好的快捷键，按弹窗提示输入Item ID和要提取的单位数量，脚本会自动完成筛选、复制到新表、删除原表已提取记录的全流程。

注意：保存文件时需要选择「Excel 启用宏的工作簿(*.xlsm)」格式，否则脚本会失效。如果Item ID不在A列、日期不在C列，只要修改代码里对应的列标即可，其他逻辑无需调整。

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