Microsoft 365 Extraire texte de toutes les zones de texte

[julien91080]

Bonjour à la communauté,

Malgré plusieurs heures de recherche, je ne trouve hélas pas mon bonheur.

J'ai un fichier contenant un grand nombre de zone de texte de type organigramme répartis selon des niveaux.

j'aimerais extraire chaque valeur de chaque zone de texte dans une cellule unique (ligne par ligne) et si possible de connaitre le "niveau" où se situait la personne.

je me suis permis de vous mettre ci joint un ficher test avec le résultat que je souhaite.

Merci 1000 fois pour votre aide.

Cordialement,

Julien

 

[djidji59430]

Bonjour à tous,

tu refais ton organigramme en supprimant tes zones de texte et en les ecrivant dans des cellules et pas des cellules fusionnées , mais des cellules dont tu adaptes la hauteur et la largeur

Crdlmt

 

[julien91080]

Bonjour,
L'idée serait que ça se fasse automatiquement/avec une routine puisque le fichier d'origine contient plus de 3000 zones de texte. Je me demandais donc s'il existait un moyen d'éviter de le faire manuellement.

Cordialement,

 

[sylvanu]

Bonjour Julien, Djidji,
Un essai en PJ avec :

Sub Worksheet_Activate()
Dim Ligne%, L%, F, strNomForme, strAdresseCellule
[A2:D1000].ClearContents
Ligne = 2: Set F = Sheets("Orga complete")
For Each img In F.Shapes
    strNomForme = img.Name
    strAdresseCellule = CStr(F.Shapes(strNomForme).TopLeftCell.Address)
    L = Split(strAdresseCellule, "$")(2)
    Cells(Ligne, "A") = F.Cells(L - 2, "B") & F.Cells(L - 1, "B") & F.Cells(L, "B") & F.Cells(L + 1, "B") & F.Cells(L + 2, "B")
    Cells(Ligne, "B") = img.TextFrame2.TextRange.Text
    ' Cells(Ligne, "C") = strAdresseCellule ' A valider si on veut l'adresse de la cellule.
    ' Cells(Ligne, "D") = strNomForme       ' A valider si on veut le nom du shape.
    Ligne = Ligne + 1
Next
End Sub

( cela suppose que le niveau soit dans une des cellules L-2 à L+2 si le shape est détecté en ligne L )
La macro est automatique lorsqu'on sélectionne la feuille Résultat.

 

[julien91080]

Bonjour Sylvanu,

Merci pour t'être posé sur mon projet.
La macro ne fonctionne malheureusement pas sur mon fichier d'origine, j'ai le message suivant:

Erreur d'execution '-2147024809 (80070057)
La valeur tapée est en dehors des limites

en débogage j'ai sur la ligne de code suivant l'erreur:
Cells(Ligne, "B") = img.TextFrame2.TextRange.Text


Cordialement

 

[sylvanu]

Bonjour,
Effectivement j'ai déjà eu ce problème, ce code semble incompatible de certaines version, peut être de celle du VBA.
Essayez cette PJ j'ai remplacé par :

Cells(Ligne, "B") = img.TextFrame.Characters.Text

 

[julien91080]

C'est juste top! ca marche du feu de dieu.

Merci beaucoup

 

[patricktoulon]

bonjour
une petite astuce qui va arranger tout le monde
en effet es propriété text de shapes selon la version devront passer par textrange ou characters
l'astuce pour satisfaire tout le monde c'est de passer par la collection drawingobjects
comme ça on passe par la propriété text directement

Sub Worksheet_Activate()
Dim Ligne%, L%, F, strNomForme, strAdresseCellule, img As Object
[A2:D1000].ClearContents
Ligne = 2: Set F = Sheets("Orga complete")
For Each img In F.DrawingObjects
    strNomForme = img.Name
    strAdresseCellule = CStr(F.Shapes(strNomForme).TopLeftCell.Address)
    L = Split(strAdresseCellule, "$")(2)
    Cells(Ligne, "A") = F.Cells(L - 2, "B") & F.Cells(L - 1, "B") & F.Cells(L, "B") & F.Cells(L + 1, "B") & F.Cells(L + 2, "B")
    On Error Resume Next
    Cells(Ligne, "B") = img.Text
    Ligne = Ligne + 1
Next
End Sub

c'est d'ailleurs valable pour d'autre propriété l'accès en est plus simple