Você pode começar com essa macro antiga e tentar personalizá-la para atender às suas necessidades, a qualquer orientação de que precisar, basta perguntar.
Sub ConcatenateAcrossColumns()
Dim data, numrows As Long, result, i As Long, n As Long
'turn off screen update
Application.ScreenUpdating = 0
'check if the data on the sheet start where the code expects it
If Range("a1") = "" Then Exit Sub
'define data range
With Range("a1", Cells(Rows.Count, "a").End(xlUp)).Resize(, 2)
'sort data range by A1
.Sort key1:=Range("a1"), Header:=xlNo
'take data to array
data = .Value
'setting variable value equal to number of rows in array
numrows = UBound(data)
'creating result array
ReDim result(1 To numrows, 1 To 1)
'start loop from 1 row to the last row of array
For i = 1 To numrows
'taking first animal name to a variable
temp = data(i, 1)
'put number of the animal to result array
result(i, 1) = result(i, 1) & data(i, 2)
'loop until value of temp not equals current animal - ex.: cat <> dog
For n = i + 1 To numrows
'if cat = cat write it's corresponding value from the second column to result array
If data(n, 1) = temp Then result(i, 1) = result(i, 1) & "," & data(n, 2) Else Exit For
Next
'going 1 row backward
i = n - 1
Next
'output result array to the sheet
.Offset(, 2).Resize(, 1) = result
End With
End Sub