Distribution structuré d'informations d'un document Word vers une feuille Excel (VBA ou Manip'?)

Bonjour à tous,

Dans l'exemple de fichier word ci-joint (6 pages, le doc réel fait 238 pages), j'ai des mots (en gras et colorié en rouge), suivi de leurs définitions sur plusieurs lignes (non-formaté et colorié en noir).

J'aurais besoin de transférer ces informations dans une feuille excel pour que le mot en question apparaisse dans une cellule et que la définition entière apparaisse dans la cellule de gauche.
J'essaye surtout d'éviter que les définitions d'un même apparaisse dans plusieurs cellules descendante à cause de marque de paragraphe ou de saut de ligne manuel.

Ex bon:
A1:
À chaux et à sable
B1:
Bâtir à chaux et à sable = très solidement.
Fam.: très robuste. “un grand gaillard bâti à chaux et à sable”

Ex mauvais:
A1:
À chaux et à sable
B1:
Bâtir à chaux et à sable = très solidement.
B2:
Fam.: très robuste. “un grand gaillard bâti à chaux et à sable"

A dispo pour échanger sur le sujet, mais toute proposition de VBA ou de manipulation seront le bienvenu.

Bonjour,

Assez simple. Recopier tout le texte du document Word (Ctrl-A) dans une feuille Excel du dossier joint (Ctrl-V), ensuite lancer la macro 'En_2_colonnes'.
Il est aussi possible de le faire en plusieurs fois sur la même feuille, ou sur plusieurs feuilles.
Seules choses à respecter:
- ne pas laisser de cellule vide en colonne 1 (la macro commence à la ligne 1 et s'arrête au moment où elle rencontre une cellule vide);
- toujours avoir la même couleur pour les mots (rouge);
- le premier mot, en ligne 1, doit avoir sa couleur caractéristique (rouge).

Code:

---

1 2 3 4 5 6 7 8 9 10 11 12 13 14 15 16 17 18 19 20 21 22 23 24 25 26 27

Sub En_2_colonnes() Dim kR As Long, kColor As Long kR = 1 kColor = Cells(kR, 1).Font.Color '--- couleur de la 1ère cellule en colonne 1 --- caractéristique '--- présentation colonnes 1 et 2 Cells.VerticalAlignment = xlTop Columns("A:A").ColumnWidth = 20 Columns("B:B").ColumnWidth = 160 Columns("B:B").WrapText = True '--- traitement While Cells(kR, 1) <> "" Debug.Print kR, Cells(kR, 1).Font.Color Cells(kR, 1).Select If Cells(kR, 1).Font.Color = kColor Then '--- cellule titre kR = kR + 1 Else '--- cellule texte If Cells(kR - 1, 2) = "" Then Cells(kR - 1, 2) = Cells(kR, 1) Else Cells(kR - 1, 2) = Cells(kR - 1, 2) & vbCrLf & Cells(kR, 1) End If Rows(kR).Delete Shift:=xlUp '--- supprime la ligne End If Wend End Sub

---

Bonne continuation.

Merci EricDgn!

le macro a marché parfaitement, et m'a même clairement montré quelques erreurs de format dans le doc word d'origine donc, nickel!

Merci encore,

D.