Discussion :

[dewilded]

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.

[EricDgn]

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 :

Sélectionner tout - Visualiser dans une fenêtre à part

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.

[dewilded]

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.