Download The Workbook

Sub Arrange_The_Data()

'Declare the variable for Input worksheet
Dim Ish As Worksheet
Set Ish = ActiveWorkbook.Sheets("Input")

'Define the Last row based on Last used cell in column B Of Input worksheet
Dim LastRow As Integer
LastRow = Ish.Range("B" & Rows.Count).End(xlUp).Row

'Declare variables for Loop variable and Range
Dim R As Integer, Rng As Range
Set Rng = Ish.Range(Cells(2, 2), Cells(LastRow, 2))

'Declare a variable for criteria in countif function
Dim CriteriaData As String

'Using Do Loop to Loop through all the rows
R = 2
Do Until Ish.Cells(R, 2).Value = ""
'For R = 2 To LastRow
Application.Wait (Now + TimeValue("00:00:01"))
Application.Speech.Speak (R)
CriteriaData = Ish.Cells(R, 2).Value
StartRow = R + 1

'Using Do Loop - Loops all the rows below to current cell
Do Until Ish.Cells(StartRow, 2).Value = ""
'If countif function returns the 1 then exit the loop
If Application.WorksheetFunction.CountIf(Rng, CriteriaData) = 1 Then
Exit Do
End If

'if countif function returns greater than one then it loop all the cells
If Application.WorksheetFunction.CountIf(Rng, CriteriaData) > 1 Then
If Trim(LCase(Ish.Cells(StartRow, 2).Value)) = Trim(LCase(Ish.Cells(R, 2).Value)) Then
Ish.Cells(R, 3).Value = Ish.Cells(R, 3).Value & "," & Ish.Cells(StartRow, 3).Value
'when value matches it deletes the row
Ish.Rows(StartRow).EntireRow.Delete
'when row deleted no need to increase the internal loop row count
GoTo DontIncreaseTheRowCount
End If
StartRow = StartRow + 1
DontIncreaseTheRowCount:
End If
Loop
R = R + 1
Loop
MsgBox "Process Completed"
End Sub