Try the following macro:
Code:
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