求Office Script/VBA脚本：合并指定列生成唯一ID并复制重复行至其他工作表

Office Script 实现 #

以下脚本会合并NUMBER、Records、Site、LC、Desc列生成唯一标识，统计重复标识并将对应整行复制到名为重复项的空白工作表中：

function main(workbook: ExcelScript.Workbook) {
    // 获取源工作表（当前活动表）和目标空白工作表
    const sourceSheet = workbook.getActiveWorksheet();
    const targetSheet = workbook.getWorksheet("重复项");
    if (!targetSheet) {
        throw new Error("请先创建名为'重复项'的空白工作表");
    }

    // 读取源数据（含表头）
    const sourceRange = sourceSheet.getUsedRange();
    const sourceValues = sourceRange.getValues();
    if (sourceValues.length <= 1) {
        console.log("无有效数据可处理");
        return;
    }

    // 定义需合并的列索引（对应表头：NUMBER=0, Records=1, Site=3, LC=4, Desc=5）
    const mergeCols = [0, 1, 3, 4, 5];
    const idCounter = new Map<string, number>();
    const duplicateRows: (string | number)[][] = [];

    // 第一遍遍历：统计每个唯一ID的出现次数
    duplicateRows.push(sourceValues[0]); // 先加入表头
    for (let i = 1; i < sourceValues.length; i++) {
        const row = sourceValues[i];
        const uniqueId = mergeCols.map(idx => row[idx]).join("|");
        idCounter.set(uniqueId, (idCounter.get(uniqueId) || 0) + 1);
    }

    // 第二遍遍历：筛选出重复行（出现次数≥2）
    for (let i = 1; i < sourceValues.length; i++) {
        const row = sourceValues[i];
        const uniqueId = mergeCols.map(idx => row[idx]).join("|");
        if (idCounter.get(uniqueId) >= 2) {
            duplicateRows.push(row);
        }
    }

    // 将结果写入目标工作表
    if (duplicateRows.length > 1) {
        const targetRange = targetSheet.getRangeByIndexes(0, 0, duplicateRows.length, duplicateRows[0].length);
        targetRange.setValues(duplicateRows);
        console.log(`完成：共提取${duplicateRows.length - 1}条重复行`);
    } else {
        console.log("未发现任何重复项");
    }
}

使用说明 #

1. 打开Excel（网页版或支持Office Script的桌面版），点击「自动化」>「新建脚本」；
2. 清空默认代码，粘贴上述脚本；
3. 确保已创建名为重复项的空白工作表；
4. 点击「运行」即可执行。

VBA 实现 #

若使用传统Excel桌面版，可使用以下VBA宏实现相同功能：

Sub ExtractDuplicateRows()
    Dim sourceSheet As Worksheet
    Dim targetSheet As Worksheet
    Dim sourceValues As Variant
    Dim idCounter As Object
    Dim uniqueId As String
    Dim i As Long
    Dim duplicateRows As Collection
    Dim rowData As Variant
    
    ' 指定源工作表（当前活动表）和目标工作表
    Set sourceSheet = ActiveSheet
    On Error Resume Next
    Set targetSheet = ThisWorkbook.Worksheets("重复项")
    On Error GoTo 0
    If targetSheet Is Nothing Then
        MsgBox "请先创建名为'重复项'的空白工作表", vbExclamation
        Exit Sub
    End If
    
    ' 读取源数据
    sourceValues = sourceSheet.UsedRange.Value
    If UBound(sourceValues) <= 1 Then
        MsgBox "无有效数据可处理", vbInformation
        Exit Sub
    End If
    
    ' 初始化字典统计ID出现次数
    Set idCounter = CreateObject("Scripting.Dictionary")
    Set duplicateRows = New Collection
    
    ' 添加表头到结果集合
    duplicateRows.Add sourceValues(1, 1 To UBound(sourceValues, 2))
    
    ' 第一遍遍历：统计ID出现次数
    For i = 2 To UBound(sourceValues)
        ' 拼接唯一ID：NUMBER(1)、Records(2)、Site(4)、LC(5)、Desc(6)
        uniqueId = sourceValues(i, 1) & "|" & sourceValues(i, 2) & "|" & _
                   sourceValues(i, 4) & "|" & sourceValues(i, 5) & "|" & sourceValues(i, 6)
        If idCounter.Exists(uniqueId) Then
            idCounter(uniqueId) = idCounter(uniqueId) + 1
        Else
            idCounter(uniqueId) = 1
        End If
    Next i
    
    ' 第二遍遍历：筛选重复行
    For i = 2 To UBound(sourceValues)
        uniqueId = sourceValues(i, 1) & "|" & sourceValues(i, 2) & "|" & _
                   sourceValues(i, 4) & "|" & sourceValues(i, 5) & "|" & sourceValues(i, 6)
        If idCounter(uniqueId) >= 2 Then
            duplicateRows.Add sourceValues(i, 1 To UBound(sourceValues, 2))
        End If
    Next i
    
    ' 将结果写入目标工作表
    If duplicateRows.Count > 1 Then
        targetSheet.Cells.ClearContents
        For i = 1 To duplicateRows.Count
            rowData = duplicateRows(i)
            targetSheet.Cells(i, 1).Resize(1, UBound(rowData)).Value = rowData
        Next i
        MsgBox "完成：共提取" & duplicateRows.Count - 1 & "条重复行", vbInformation
    Else
        MsgBox "未发现任何重复项", vbInformation
    End If
End Sub

使用说明 #

1. 打开Excel，按Alt+F11进入VBA编辑器；
2. 右键点击工作簿，选择「插入」>「模块」；
3. 粘贴上述代码，关闭编辑器；
4. 确保已创建名为重复项的空白工作表；
5. 按Alt+F8选择「ExtractDuplicateRows」并点击「运行」。

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