Excel VBA on how to skip the first adjacent cell and copy the values of the next 5 adjacent cells from the skipped cell?

I am looking for a way that once a duplicate value is found the 6 cells adjacent to it will be copied to i2. But I want to skip the first cell adjacent to the duplicate value found which is a date value and the remaining 5 adjacent cells to be copied. Is this possible ?

Sub FindDuplicatesrevision()

Range("i2:q500").ClearContents


On Error GoTo ErrorHandler

' Define the input and output ranges
Dim inputRange As Range
Set inputRange = Range("A2:A500")
Dim outputRange As Range
Set outputRange = Range("I2")

' Define a dictionary object to store the counts of each value
Dim dict As Object
Set dict = CreateObject("Scripting.Dictionary")

' Loop through each cell in the input range
Dim cell As Range
For Each cell In inputRange
    Dim value As Variant
    value = cell.value
    
    ' If the value is not empty, add it to the dictionary
    If Not IsEmpty(value) Then
        If dict.Exists(value) Then
            ' If the value already exists in the dictionary, increment the count
            dict(value) = dict(value) + 1
        Else
            ' If the value does not exist in the dictionary, add it with a count of 1
            dict.Add value, 1
        End If
    End If
Next cell

' Output the duplicate values to the output range
Dim row As Integer
row = 1

' Output any empty cells first
For Each key In dict.keys
    If IsEmpty(key) Then
        outputRange.Offset(row, 0).value = ""
        row = row + 1
    End If
Next key

' Output the non-empty duplicate values to the output range
For Each key In dict.keys
    If Not IsEmpty(key) And dict(key) > 1 Then
        outputRange.Offset(row, 0).value = key
        outputRange.Offset(row, 1).value = dict(key)
        row = row + 1
    End If
Next key

' Format the output range as a table
Dim tableRange As Range
Set tableRange = outputRange.CurrentRegion
tableRange.Select
ActiveSheet.ListObjects.Add(xlSrcRange, tableRange, , xlYes).Name = "DuplicatesTable"

Exit Sub



ErrorHandler:
MsgBox "No duplicate values found in the input range."

Call Wingdings
Call FindDuplicatesAndCopy

    End Sub

Sub Wingdings()

' Define the input and output ranges
Dim inputRange As Range
Set inputRange = Range("J2:J500")
Dim outputRange As Range
Set outputRange = Range("K2")

' Loop through each cell in the input range
Dim cell As Range
For Each cell In inputRange
    ' If the cell is not empty, add an arrow symbol to the output range
    If Not IsEmpty(cell.value) Then
        outputRange.value = ChrW(&H2192) ' Arrow symbol in Wingdings font
    End If
    ' Move to the next row in the output range
    Set outputRange = outputRange.Offset(1, 0)
Next cell

End Sub


[![enter image description here][1]][1]Sub FindDuplicatesAndCopy()

' Define the input and output ranges
Dim inputRange As Range
Set inputRange = Range("A2:A500")
Dim outputRange As Range
Set outputRange = Range("L2")

' Define a dictionary object to store the counts of each value
Dim dict As Object
Set dict = CreateObject("Scripting.Dictionary")

' Loop through each cell in the input range
Dim cell As Range
For Each cell In inputRange
    Dim value As Variant
    value = cell.value
    
    ' If the value is not empty, add it to the dictionary
    If Not IsEmpty(value) Then
        If dict.Exists(value) Then
            ' If the value already exists in the dictionary, set the flag to skip the next adjacent cell
            dict(value) = True
        Else
            ' If the value does not exist in the dictionary, add it with a flag to not skip the next adjacent cell
            dict.Add value, False
        End If
    End If
Next cell

' Loop through the input range again and copy the next 6 adjacent cells for each duplicate value
Dim outputRow As Integer
outputRow = 1
For Each cell In inputRange
    Dim valuea As Variant
    valuea = cell.value
    
    ' If the value is not empty and has a flag to skip the next adjacent cell
    If Not IsEmpty(valuea) And dict(valuea) Then
        ' Copy the next 6 adjacent cells to the output range
        outputRange.Offset(outputRow, 0).Resize(1, 6).value = cell.Offset(0, 1).Resize(1, 6).value
        outputRow = outputRow + 1
        dict(valuea) = False ' Reset the flag to not skip the next adjacent cell
    End If
Next cell

' Check if any duplicates were found
If outputRow = 1 Then
    MsgBox "No duplicates found."
End If

End Sub

As in this picture its copies the first adjacent cell which is Date values which i dont really need.

[All values are being taken from A2:A500. When a duplicate value is found it will copy the 6 cells to its right and display the results on cell i2. What i am looking for is to copy the 6 cells but skip the cell containing the date value. Which means skip the first adjacent cell (Date value) and copy the remaining five other adjacent cells right after the skipped adjacent cell.]

Solution

This 1 in this line cell.Offset(0, 1) means you are starting 1 cell to the right of your input range. If you want to skip the 1st cell and start at the 2nd cell, use cell.Offset(0, 2).

Also if you only want to copy 5 cells instead of 6, use .Resize(1, 5) instead of .Resize(1, 6)

Instead of:

 outputRange.Offset(outputRow, 0).Resize(1, 6).value = cell.Offset(0, 1).Resize(1, 6).value

Try:

 outputRange.Offset(outputRow, 0).Resize(1, 5).value = cell.Offset(0, 2).Resize(1, 5).value