Macro para Ordenar

Buen Dia Expertos,

Tengo una Macro que me sirve para ordenar dos columnas A y B y las reordena a partir de la D:

en la primera están los CLIENTES y en la segunda están los DEPARTAMENTOS a los que le corresponde, coloca solo una vez al cliente y en las siguientes columnas los departamentos a los que le corresponde, y si hay repetidos solo cuenta uno.

El único problema en esta macro es que demora mucho porque la utilizo para bases grandes. Agradecería que me apoyen para poder resolver este problema de lentitud.

Sub prueba()
Range("a1").Select
Dim i As Integer
Do
i = ActiveCell.Row
buscando = ActiveCell.Value
fila = ActiveCell.Row
If Range("d:d").Find(buscando) Is Nothing Then
Range("D" & fila).Value = buscando
Range("D" & fila).Offset(0, 1).Value = ActiveCell.Offset(0, 1).Value
Else
fila2 = Range("d:d").Find(buscando).Row
If Range(Range("d" & fila2), Range("d" & fila2).End(xlToRight)).Find(ActiveCell.Offset(0, 1).Value) Is Nothing Then
Range("d:d").Find(buscando).End(xlToRight).Offset(0, 1).Value = ActiveCell.Offset(0, 1).Value
End If
End If
i = i + 1
Range("a" & i).Select
Loop While ActiveCell.Value <> ""
End Sub