Copie Zone Texte

[maval]

Bonjour


J'ai sur une feuille Excel un groupe de Zone Texte avec des noms de ville.
Est-il possible en VBA de copier l'ensemble des zone texte dans une colonne ex."B3"

je joint mon fichier exemple

Je vous remercie d'avance

 

[NezQuiCoule]

Re : Copie Zone Texte

Bonjour maval,

Oui bien sûr, essaie le code ci-dessous :

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

Bonne journée

 

[job75]

Re : Copie Zone Texte

Bonjour maval,

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

Edit : bonjour NezQuiCoule, oui votre solution est plus simple, mais il faut qu'il n'y ait que des rectangles dans le groupe.

A+

 

[job75]

Re : Copie Zone Texte

Re,

Deux remarques.

1) La solution de NezQuiCoule fonctionne sur Excel 2010 mais pas sur Excel 2003.

2) Ma solution n'affichait pas toute la liste, j'avais oublié le + 1 :

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

Je corrige le poste précédent.

A+

 

[job75]

Re : Copie Zone Texte

Re,

Pour éviter de dégrouper-regrouper, une solution qui fonctionne sur Excel 2003 :

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

A+

 

[Efgé]

Re : Copie Zone Texte

Bonjour maval, NezQuiCoule Bonjour Job

Surtout pour saluer Job,

J'ai testé la dernière proposition de Job75 sous 2007 : C'est OK

Une variante de la même, sans transpose ni select:

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

Cordialement

 

[job75]

Re : Copie Zone Texte

Bonjour Efgé, heureux de te croiser,

Si j'utilise .Select c'est pour que la solution fonctionne aussi sur Excel 2003.

Ta solution ne fonctionne pas sur 2003.

A+

 

[maval]

Re : Copie Zone Texte

Bonjour NezQuiCoule, Efgé, Job

Je vous remercie beaucoup Nickel

Je vous souhaite une très bonne journée