Microsoft 365 Extraire texte de toutes les zones de texte

julien91080 · 27 Novembre 2023

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 · 27 Novembre 2023

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 · 27 Novembre 2023

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 · 27 Novembre 2023

Bonjour Julien, Djidji,
Un essai en PJ avec :

VB:

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 · 28 Novembre 2023

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 · 28 Novembre 2023

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 :

VB:

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

julien91080 · 28 Novembre 2023

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

Merci beaucoup

patricktoulon · 28 Novembre 2023

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

VB:

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

Microsoft 365 Extraire texte de toutes les zones de texte

julien91080

XLDnaute Occasionnel

Pièces jointes

djidji59430

XLDnaute Barbatruc

julien91080

XLDnaute Occasionnel

sylvanu

XLDnaute Barbatruc

Pièces jointes

julien91080

XLDnaute Occasionnel

sylvanu

XLDnaute Barbatruc

Pièces jointes

julien91080

XLDnaute Occasionnel

patricktoulon

XLDnaute Barbatruc

Discussions similaires