[macro commande] : fusion de cellules identiques

[Prissou]

Bonjour,

Nous avons un gros fichier Word dans lequel nous devons procéder à la fusion des éléments des cellules identiques dans une même colonne:

colonne 1 |colonne 2 | colonne 3 | colonne 4 |
1
1
1
2
2
3
3
3
etc..

Voilà après avoir fouiller sur le forum, nous avons trouver un code mais qui malheureusement n'est pas parfait. Il ne fusionne que 2 lignes par 2 lignes.

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
28
29
30
31
32
33
34
35
36
37
38
39
Sub fusion()
Dim plign, nbl, n As Long
Dim cref As Byte
Dim ref, refs  As Variant
'1ère ligne de données du tableau
plign = 1
'N° de la colonne contenant la référence client (à modifier éventuellement)
cref = 1
 
 
 
'Déterminer la dernière ligne du tableau
nbl = 15
 
'Modifier les 7 "adretour" avec vos adresses réelles
Testval:
If plign > nbl Then
GoTo Fin
End If
 
ActiveDocument.Tables(1).Cell(plign, cref).Select
ref = Selection
plign = plign + 1
ActiveDocument.Tables(1).Cell(plign, cref).Select
refs = Selection
If ref = refs Then
ActiveDocument.Tables(1).Cell(plign, cref).Select
Selection.Delete Unit:=wdCharacter, Count:=1
Selection.MoveUp Unit:=wdLine, Count:=1, Extend:=wdExtend
Selection.Cells.Merge
GoTo Testval
Else
GoTo Testval
End If
 
Fin:
If ActiveDocument.Saved = False Then ActiveDocument.Save
 
End Sub

Si quelqu'un voit l'erreur..

Merci d'avance

[jacques_jean]

Bonjour Prissou,

J'ai reconnu le code que j'avais écrit pour un autre utilisateur.
Vous l'avez un tout petit peu modifié mais il n'est sans doute pas tout à fait adapté à votre besoin.

Vous voulez bien que seules les cellules de la colonne 1 soit fusionnées ?

Je mets le code en forme dès réception de votre réponse.

Amicalement.

[jacques_jean]

Re Prissou,

J'ai relu votre sujet et finalement j'ai la réponse, il semble bien que vous ne vouliez fusionner que les 1ères cellules donc copiez ce code dans la fenêtre VBA après avoir sélectionné This document :

Sub Fusion()
Dim plign, nbl, n As Long
Dim cref As Byte
Dim ref, refs As Variant
'1ère ligne de données du tableau
plign = 1
'N° de la colonne contenant la référence client (à modifier éventuellement)
cref = 1
n = 0


'Déterminer la dernière ligne du tableau

nbl = Tables(1).Rows.Count

Testval:
If plign > nbl Then
If ActiveDocument.Saved = False Then ActiveDocument.Save
Exit sub
End If

ActiveDocument.Tables(1).Cell(plign, cref).Select
ref = Selection
plign = plign + 1 + n
ActiveDocument.Tables(1).Cell(plign, cref).Select
refs = Selection
If ref = refs Then
ActiveDocument.Tables(1).Cell(plign, cref).Select
'Selection.Delete Unit:=wdCharacter, Count:=1
Selection.Delete
Selection.MoveUp Unit:=wdLine, Count:=1, Extend:=wdExtend
Selection.Cells.Merge
n = n + 1
plign = plign - n
GoTo Testval
Else
n = 0
GoTo Testval
End If

End Sub

Amicalement.