VBA从第二列查找重复项并导出到第二行

Sub FindDuplicates()
    Dim ws As Worksheet
    Dim lastRow As Long
    Dim duplicates As Range
    Dim cell As Range
    
    ' 设置要操作的工作表
    Set ws = ThisWorkbook.Worksheets("Sheet1") ' 将"Sheet1"替换为实际的工作表名称
    
    ' 获取最后一行的行号
    lastRow = ws.Cells(ws.Rows.Count, 2).End(xlUp).Row ' 2表示第二列，根据实际情况修改
    
    ' 在第二行创建一个新的工作区
    ws.Rows(2).ClearContents
    
    ' 遍历第二列的单元格，查找重复项
    For Each cell In ws.Range("B2:B" & lastRow) ' B2表示第二列的起始单元格，根据实际情况修改
        If Application.WorksheetFunction.CountIf(ws.Range("B2:B" & cell.Row), cell.Value) > 1 Then
            ' 如果单元格的值在当前范围内出现多次，则将其添加到重复项范围
            If duplicates Is Nothing Then
                Set duplicates = cell
            Else
                Set duplicates = Union(duplicates, cell)
            End If
        End If
    Next cell
    
    ' 将重复项导出到第二行
    If Not duplicates Is Nothing Then
        duplicates.Copy ws.Rows(2)
    End If
    
    ' 清除剪贴板中的内容
    Application.CutCopyMode = False
    
    ' 提示完成
    MsgBox "重复项已导出到第二行。"
End Sub