Como puedo mejorar macro para buscar y pegar datos

Para Elsamatilde. Buen día me puedes apoyar en mejora la macro para buscar y pegar datos en una tabla de excel.

Sub AgruparDatosHorizontal()
Dim Arr As Variant, tmp As Variant, i As Integer
Dim objDic As Object, varItems As Variant, varKeys As Variant

Arr = Worksheets("VBA").Range("G1").CurrentRegion

Set objDic = CreateObject("Scripting.Dictionary")

For i = 1 To UBound(Arr)
objDic(Arr(i, 1)) = objDic(Arr(i, 1)) & Arr(i, 2) & "###"
Next

varKeys = objDic.keys
varItems = objDic.items

With Worksheets("VBA")
For i = 1 To objDic.Count
tmp = Split(varItems(i - 1), "###")
.Cells(i, 10) = varKeys(i - 1)
.Cells(i, 11).Resize(, UBound(tmp)) = tmp
Next
End With

End Sub