Excel VBA需求：找到重复值后跳过首邻日期单元格复制后续5个单元格

以下是调整后的代码，会在A2:A500区域识别重复值，跳过重复值右侧第一个日期类型单元格，仅复制后续5个相邻单元格内容到I2起始区域：

Sub CopyDuplicateDataSkipDate()
    Dim ws As Worksheet
    Dim lastRow As Long, i As Long, pasteRow As Long
    Dim duplicateDict As Object
    Dim currentVal As Variant
    Dim targetRange As Range
    
    Set ws = ActiveSheet
    Set duplicateDict = CreateObject("Scripting.Dictionary")
    pasteRow = 2 ' 从I2开始粘贴
    
    ' 先遍历记录所有重复值
    lastRow = ws.Cells(ws.Rows.Count, "A").End(xlUp).Row
    For i = 2 To lastRow
        currentVal = ws.Cells(i, "A").Value
        If Not duplicateDict.Exists(currentVal) Then
            duplicateDict(currentVal) = 1
        Else
            duplicateDict(currentVal) = duplicateDict(currentVal) + 1
        End If
    Next i
    
    ' 遍历处理重复值的内容复制
    For i = 2 To lastRow
        currentVal = ws.Cells(i, "A").Value
        ' 仅处理出现次数大于1的重复值
        If duplicateDict(currentVal) > 1 Then
            ' 判断右侧第一个单元格是否为日期类型
            If IsDate(ws.Cells(i, "B").Value) Then
                ' 跳过日期单元格，复制后续5个单元格（C到G列）
                Set targetRange = ws.Range(ws.Cells(i, "C"), ws.Cells(i, "G"))
            Else
                ' 非日期场景保留原复制范围（可根据需求调整）
                Set targetRange = ws.Range(ws.Cells(i, "B"), ws.Cells(i, "G"))
            End If
            ' 粘贴到目标区域
            targetRange.Copy ws.Cells(pasteRow, "I")
            pasteRow = pasteRow + 1
        End If
    Next i
    
    ' 释放对象
    Set duplicateDict = Nothing
    Set ws = Nothing
    Set targetRange = Nothing
End Sub

关键修改说明 #

• 用IsDate()函数检测重复值右侧第一个单元格的类型，精准跳过日期单元格
• 日期场景下将复制范围调整为重复值右侧第2到第6个单元格（共5个）
• 用字典记录重复值出现次数，避免无效处理非重复项

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