Extraer valores únicos, pegar y contar repeticiones

Ok, ahora te lo mando

Te mando la solución, sigue mi ejemplo:

Tenemos en la columna A desde A2 hacia abajo todos los países (en A1 tengo un rótulo "países")

-Ejecuta esta macro y te presentará el informe que precisas en la columna D

Sub ejemplo()
'por luismondelo
fila = 1
Range("a1").CurrentRegion.Sort key1:=Range("a1"), order1:=xlAscending, Header:=xlYes, ordercustom:=1, MatchCase:=False, Orientation:=xlTopToBottom
Range("a2").Select
Do While ActiveCell.Value <> ""
valor = ActiveCell.Value
contarsi = Application.WorksheetFunction.CountIf(Columns(1), valor)
Cells(fila, 4).Value = ActiveCell.Value & " " & contarsi
fila = fila + 1
Do While ActiveCell.Value = valor
ActiveCell.Offset(1, 0).Select
Loop
Loop
End Sub

no olvides finalizar la consulta

Hola Luis,

Gracias por tu pronto respuesta.

El resultado de ejecutar el código es correcto. El único problemas que ordena la columna "países" agrupándolos. ¿Se podría conservar la posición original de los datos?.

En cuanto al resultado de contar cada país, podría reflejarse en una columna adjunta, la "E". Esto fue error mio al plantear el problema.

Quedo a la espera de tus comentarios.

Claro, aquí te mando la nueva macro. Tenemos los datos colocados como antes. Ejecuta esta macro y todo solucionado.

Sub ejemplo()
'por luismondelo
fila = 1
Range("a2").Select
Do While ActiveCell.Value <> ""
If InStr(valores, ActiveCell) = 0 Then
valores = valores & "," & ActiveCell
End If
ActiveCell.Offset(1, 0).Select
Loop
valores = Mid(valores, 2, Len(valores) - 1)
valores = Split(valores, ",")
For x = 0 To UBound(valores)
contarsi = Application.WorksheetFunction.CountIf(Columns(1), valores(x))
Cells(fila, 4).Value = valores(x)
Cells(fila, 5).Value = contarsi
fila = fila + 1
Next
End Sub

no olvides finalizar la consulta