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