Excel VBA如何提取指定列重复值并连带对应列内容复制到其他工作表

修改后的代码可直接实现需求，优化了原有代码的逻辑冗余、判断列错误、整行复制的问题：

Sub FindPIDDuplicates()
    Dim wstSource As Worksheet, wstOutput As Worksheet
    Dim lastRow As Long, i As Long, outputRow As Long
    
    ' 定义源表和目标表
    Set wstSource = ThisWorkbook.Worksheets("Sheet1")
    Set wstOutput = ThisWorkbook.Worksheets("Sheet2")
    
    Application.ScreenUpdating = False
    outputRow = 2 ' 目标表从第二行开始写数据，第一行放表头
    
    ' 复制B、D列表头到目标表，可根据需要调整目标列位置
    wstOutput.Range("A1").Value = wstSource.Range("B1").Value
    wstOutput.Range("B1").Value = wstSource.Range("D1").Value
    
    ' 获取源表B列最后一行行号
    lastRow = wstSource.Cells(wstSource.Rows.Count, "B").End(xlUp).Row
    
    ' 遍历源表判断B列值是否重复
    For i = 2 To lastRow
        If Application.WorksheetFunction.CountIf(wstSource.Range("B:B"), wstSource.Range("B" & i).Value) > 1 Then
            ' 写入对应行的B、D列值到目标表
            wstOutput.Range("A" & outputRow).Value = wstSource.Range("B" & i).Value
            wstOutput.Range("B" & outputRow).Value = wstSource.Range("D" & i).Value
            outputRow = outputRow + 1
        End If
    Next i
    
    Application.ScreenUpdating = True
End Sub

代码说明 #

• 重复判断逻辑直接针对B列，完全匹配需求场景
• 仅提取重复行的B、D两列数据写入目标表，无冗余内容
• 遍历逻辑兼容性更强，不会因源表数据范围变化出现执行错误
• 如果需要目标表中B列、D列的位置和源表保持一致，只需修改赋值部分的目标列号即可

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