Sub MergeRows()
Application.ScreenUpdating = False
Dim LRow As Long, LCol As Long, strAddr As String
Dim I As Long, J As Long, bMatch As Boolean
On Error GoTo Abort
With ActiveSheet
  With .Cells.SpecialCells(xlCellTypeLastCell)
    strAddr = .Address
    LRow = .Row
    LCol = .Column
  End With
  'Sort the records by employee within department
  With .Sort
    .SortFields.Clear
    .SortFields.Add Key:=Range("C2:C" & LRow), SortOn:=xlSortOnValues, Order:=xlAscending, DataOption:=xlSortNormal
    .SortFields.Add Key:=Range("A2:A" & LRow), SortOn:=xlSortOnValues, Order:=xlAscending, DataOption:=xlSortNormal
    .SortFields.Add Key:=Range("B2:B" & LRow), SortOn:=xlSortOnValues, Order:=xlAscending, DataOption:=xlSortNormal
    .SetRange Range("A1:" & strAddr)
    .Header = xlYes
    .MatchCase = False
    .Orientation = xlTopToBottom
    .SortMethod = xlPinYin
    .Apply
  End With
  'Convert all employee names to proper case
  For I = 2 To LRow
    For J = 1 To 2
      .Cells(I, J).Value = WorksheetFunction.Proper(.Cells(I, J).Value)
    Next
  Next I
  'Merge employee records
  For I = LRow To 3 Step -1
    bMatch = True
    Application.StatusBar = "Processing " & .Cells(I, 3).Value
    For J = 1 To 3
      If .Cells(I, J).Value <> .Cells(I - 1, J).Value Then
        bMatch = False
        Exit For
      End If
    Next J
    If bMatch = True Then
      For J = 4 To LCol
        If Trim(.Cells(I, J).Value) <> "" Then
          .Cells(I - 1, J).Value = .Cells(I, J).Value
        End If
      Next J
      .Rows(I).EntireRow.Delete
    End If
  Next I
  'Re-sort records by employee
  With .Sort
    .SortFields.Clear
    .SortFields.Add Key:=Range("A2:A" & LRow), SortOn:=xlSortOnValues, Order:=xlAscending, DataOption:=xlSortNormal
    .SortFields.Add Key:=Range("B2:B" & LRow), SortOn:=xlSortOnValues, Order:=xlAscending, DataOption:=xlSortNormal
    .SortFields.Add Key:=Range("C2:C" & LRow), SortOn:=xlSortOnValues, Order:=xlAscending, DataOption:=xlSortNormal
    .SetRange Range("A1:" & strAddr)
    .Header = xlYes
    .MatchCase = False
    .Orientation = xlTopToBottom
    .SortMethod = xlPinYin
    .Apply
  End With
End With
Application.StatusBar = "Done!!"
GoTo Terminate
Abort:
MsgBox "Processing Error On Line " & I + 1, vbCritical
Terminate:
Application.ScreenUpdating = True
End Sub