Copie Zone Texte

Sub Lister_Textes()
    
    i = 3
    For Each Item In ActiveSheet.Shapes("Groupe_Pays").GroupItems
        Cells(i, 2) = Item.TextEffect.Text
        i = i + 1
    Next
    
End Sub

Sub ListeTexteShapes()
Dim s As Shape, t$, a
Application.ScreenUpdating = False
On Error Resume Next 'si Groupe_Pays n'existe pas
With ActiveSheet
  '---dégroupage---
  .Shapes("Groupe_Pays").Ungroup
  '---création de la liste---
  For Each s In .Shapes
    If s.Name Like "Rectangle*" Then
      t = t & Chr(1) & s.TextFrame.Characters.Text
    End If
  Next
  t = Mid(t, 2)
  '---Groupage---
  For Each s In .Shapes
    If s.Name Like "Rectangle*" Then s.Select False
  Next
  Selection.ShapeRange.Group.Name = "Groupe_Pays"
  ActiveCell.Activate
  '---restitution en B3---
  a = Split(t, Chr(1))
  .Range("B3:B" & .Rows.Count) = "" 'RAZ
  .[B3].Resize(UBound(a) + 1) = Application.Transpose(a)
  .[B3].Resize(UBound(a) + 1).Sort .[B3], xlAscending, Header:=xlNo 'tri
End With
End Sub

'---
  .[B3].Resize(UBound(a) + 1) = Application.Transpose(a)
  .[B3].Resize(UBound(a) + 1).Sort .[B3], xlAscending, Header:=xlNo 'tri

Sub ListeTexteShapes()
Dim s As Shape, t$, a
Application.ScreenUpdating = False
With ActiveSheet
  '---création de la liste---
  For Each s In .Shapes("Groupe_Pays").GroupItems
    s.Select
    If s.Name Like "Rectangle*" Then _
      t = t & Chr(1) & s.TextFrame.Characters.Text
  Next
  ActiveCell.Activate
  t = Mid(t, 2)
  a = Split(t, Chr(1))
  '---restitution en B3---
  .Range("B3:B" & .Rows.Count) = "" 'RAZ
  .[B3].Resize(UBound(a) + 1) = Application.Transpose(a)
  .[B3].Resize(UBound(a) + 1).Sort .[B3], xlAscending, Header:=xlNo
End With
End Sub

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