Sub ListeTexteShapes_2()
Dim s As Shape, t As Variant, i&
With ActiveSheet
With .Shapes("Groupe_Pays")
ReDim t(1 To .GroupItems.Count, 1 To 2)
For Each s In .GroupItems
If s.Name Like "Rectangle*" Then
i = i + 1
t(i, 1) = s.TextFrame.Characters.Text
End If
Next s
End With
.Range("B3:B" & .Rows.Count).ClearContents
.[B3].Resize(i, 1) = t
.[B3].Resize(i).Sort .[B3], xlAscending, Header:=xlNo
End With
End Sub