Combining Duplicate Data with Criteria

[sakrams]

Hello All,

Wondering if the gurus help me with a formula which would achieve the following looking at the table below. I have more than 1570 records that needs to be fixed.

I have duplicate Names in Column A. Column B and Column C has different dates. I want to combine them all looking at the Name but only keep the Oldest Date from Start Date and the Newest Date from Finish Date.

Original Data

Name	Start Date <tbody> </tbody>	Finish Date <tbody> </tbody>
S-301 <tbody> </tbody>	4-Mar-18 <tbody> </tbody>	4-Mar-18 <tbody> </tbody>
S-301 <tbody> </tbody>	6-Mar-18 <tbody> </tbody>	8-Mar-18 <tbody> </tbody>
S-301 <tbody> </tbody>	7-Mar-18 <tbody> </tbody>	8-Mar-18 <tbody> </tbody>
S-301 <tbody> </tbody>	4-Mar-18 <tbody> </tbody>	9-Mar-18 <tbody> </tbody>
V-351	6-Mar-18 <tbody> </tbody>	7-Mar-18 <tbody> </tbody>
V-351	7-Mar-18 <tbody> </tbody>	9-Mar-18 <tbody> </tbody>
V-351	9-Mar-18 <tbody> </tbody>	11-Mar-18 <tbody> </tbody>

<tbody>
</tbody>

Result

Name <tbody> </tbody>	Start Date <tbody> </tbody>	Finish Date <tbody> </tbody>
S-301 <tbody> </tbody>	4-Mar-18 <tbody> </tbody>	9-Mar-18 <tbody> </tbody>
V-351 <tbody> </tbody>	6-Mar-18 <tbody> </tbody>	11-Mar-18 <tbody> </tbody>

<tbody>
</tbody>

 

[wideboydixon]

Give this a try:

Public Sub ConsolidateRows()

Dim lastRow As Long
Dim thisRow As Long

lastRow = Cells(Rows.Count, "A").End(xlUp).Row
thisRow = 3
Do While thisRow <= lastRow
    If Cells(thisRow, "A").Value = Cells(thisRow - 1, "A").Value Then
        If Cells(thisRow, "B").Value < Cells(thisRow - 1, "B").Value Then Cells(thisRow - 1, "B").Value = Cells(thisRow, "B").Value
        If Cells(thisRow, "C").Value > Cells(thisRow - 1, "C").Value Then Cells(thisRow - 1, "C").Value = Cells(thisRow, "C").Value
        Cells(thisRow, "A").EntireRow.Delete
        lastRow = lastRow - 1
    Else
        thisRow = thisRow + 1
    End If
Loop

End Sub

WBD

 

[sakrams]

This is amazing Wideboydixon. It worked magic. Thanks a million for all your help.

Give this a try:

Public Sub ConsolidateRows()

Dim lastRow As Long
Dim thisRow As Long

lastRow = Cells(Rows.Count, "A").End(xlUp).Row
thisRow = 3
Do While thisRow <= lastRow
    If Cells(thisRow, "A").Value = Cells(thisRow - 1, "A").Value Then
        If Cells(thisRow, "B").Value < Cells(thisRow - 1, "B").Value Then Cells(thisRow - 1, "B").Value = Cells(thisRow, "B").Value
        If Cells(thisRow, "C").Value > Cells(thisRow - 1, "C").Value Then Cells(thisRow - 1, "C").Value = Cells(thisRow, "C").Value
        Cells(thisRow, "A").EntireRow.Delete
        lastRow = lastRow - 1
    Else
        thisRow = thisRow + 1
    End If
Loop

End Sub

WBD

 

[wideboydixon]

No problem. It's about the third similar query in two days so I'm getting used to writing them now