Search code examples
vbaexcelconsolidation

Use Excel VBA to find column matches & merge based on the values of two other column

I have a little conundrum here & while there's a few suggestions on the site, there's nothing that quite fits the bill for me. I need to merge some rows based on the values of some cells in the row.

I guess I need some sort of code that matches the name then searches for a 'New Starter' entry with that same name.

Here's how my data (Shift, name, detail) looks:

09:00-17:00 Smith John      Present
09:00-11:00 Smith John      New Starter
11:10-13:00 Smith John      New Starter
14:00-17:00 Smith John      New Starter
09:00-17:00 Connor Sarah    Present
09:00-11:00 Connor Sarah    New Starter
11:10-13:00 Connor Sarah    New Starter
14:00-17:00 Connor Sarah    New Starter
09:00-17:00 Claus Santa     Present
10:00-18:00 Mouse Mickey    Present
10:00-11:00 Mouse Mickey    New Starter
11:10-13:00 Mouse Mickey    New Starter
14:00-18:00 Mouse Mickey    New Starter

I need to remove the New Starter lines (If they exist) but also replace their 'Present' cell with 'New Starter' (Although this can be different text if needed):

09:00-17:00 Smith John      New Starter
09:00-17:00 Connor Sarah    New Starter
09:00-17:00 Claus Santa     Present
10:00-18:00 Mouse Mickey    New Starter

You can see here that Santa is not a New Starter & therefore stays as 'Present'.

Essentially, the 'New Starter' lines are not needed, but I do want to give new starters a different detail to the present staff.

Additional notes:

  • A 'Present' line will always exist if a 'New Starter' exists. If they have a 'Day Off', there'll just be a 'Day Off' line which I've already included in other Subs to extract.
  • The data to keep is whatever is in the "Present" line, only replacing that title (Column C).
Solution

  • The following code should address your conditions. Tested Working.

    Sub RemoveDups()

Dim CurRow As Long, LastRow As Long, SrchRng As Range

LastRow = Range("A" & Rows.Count).End(xlUp).Row

    Range("A1:C" & LastRow).Select
    Sheets(1).Sort.SortFields.Clear
    Sheets(1).Sort.SortFields.Add Key:=Range("B2:B" & LastRow) _
        , SortOn:=xlSortOnValues, Order:=xlAscending, DataOption:=xlSortNormal
    Sheets(1).Sort.SortFields.Add Key:=Range("C2:C" & LastRow) _
        , SortOn:=xlSortOnValues, Order:=xlAscending, DataOption:=xlSortNormal
    With Sheets(1).Sort
        .SetRange Range("A1:C" & LastRow)
        .Header = xlYes
        .MatchCase = False
        .Orientation = xlTopToBottom
        .SortMethod = xlPinYin
        .Apply
    End With

For CurRow = LastRow To 2 Step -1
    If Range("C" & CurRow).Value = "Present" Then
        If CurRow <> 2 Then
            If Not Range("B2:B" & CurRow - 1).Find(Range("B" & CurRow).Value, LookIn:=xlValues, LookAt:=xlWhole) is Nothing Then
                Range("C" & CurRow).Value = "New Starter"
            End If
        End If
    ElseIf Range("C" & CurRow).Value = "New Starter" Then
        Range("C" & CurRow).EntireRow.Delete xlShiftUp
    End If
Next CurRow

End Sub