Comment fusionner 3 cellules par macro ?

Version imprimable

Bonjour,

Je souhaite renseigner une feuille depuis une autre feuille. Les colonnes D à G de ma feuille cible doivent être fusionnées par ligne.

Pour celà, j'ai codé:
Code:

1 2 3 4 5 6 With Worksheets("Feuil1").Range("E" & k & ":G" & k) .MergeCells = False .MergeCells = True .HorizontalAlignment = xlCenter .VerticalAlignment = xlCenter End With
Après exécution, mes cellules ne sont pas fusionnées. Pourquoi ?

27/04/2015, 12h28
Invité

bonjour,
test avec .MergeCells =true
27/04/2015, 12h28
78chris

Bonjour

Sachant que la fusion de cellules est une des plaies d'Excel, ne serait-il pas plus judicieux de centrer sur les trois colonnes (centrer sur plusieurs colonnes), : résultat visuel identique sans les inconvénients des fusions ?
27/04/2015, 12h31
gnain

Code:

Worksheets("Feuil1").Range("E" & k & ":G" & k).Merge

Le centrage sur plusieurs colonnes me paraît être une bonne idée mais l'instruction que j'ai trouvé sur le web ne fonctionne pas:
Code:

1 2 3 4 With Worksheets("Feuil1").Range("E" & k & ":G" & k) .HorizontalAlignment = xlCenterAcrossSelection .VerticalAlignment = xlCenter End With

27/04/2015, 13h40
78chris
Re

Il faut adresser les cellules pas le range
Code:

1 2 3 4 5 With Worksheets("Feuil1").Range("E" & k & ":G" & k).Cells .VerticalAlignment = xlCenter .HorizontalAlignment = xlCenterAcrossSelection End With
J'ai inversé les 2 lignes car il arrive, très occasionnellement, que le centrage vertical impacte l'autre (en général sur des fichiers issus d'une ancienne version)
27/04/2015, 14h49
juju05

Adresser les cellules ne change rien. Lorsque je regarde le format de cellule dans l'onglet alignement, je l'ai toujours centré.

Je ne sais plus quoi faire :(
27/04/2015, 15h33
78chris

RE

Chez moi cela fonctionne avec le code que j'ai posté mais mes cellules n'étaient pas fusionnées au préalable...
27/04/2015, 16h27
juju05

Le classeur est enregistré sous Excel 1997-2003.
27/04/2015, 16h43
78chris

Re

Cela fonctionne aussi sur un xls : as-tu bien recopier mon code ?

Oui, voici l'intégralité de mon code :

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
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
59
60
61
62
63
64
65
66
67
68
69
70
71
72
73
74
75
76
77
78
79
80
81
82
83
84
85
86
87
88
89
90
91
92
93
94
95
96
97
98
99
100
   Dim tabCellules(), compteur As Integer
   Dim cellule As Range
   Dim b As Integer
   Dim i As Integer, j As Integer, k As Integer
   Dim rfound As Range
   Dim nb_lignes As Long
 
 
 
   ' stockage des lignes sélectionnées par clic-droit
   compteur = 0
 
   For Each cellule In Selection
       ReDim Preserve tabCellules(compteur)
       tabCellules(compteur) = cellule.Row
       compteur = compteur + 1
   Next cellule
 
   If compteur = 0 Then
      MsgBox "Aucune ligne n'a été sélectionnée. Veuillez sélectionner une ligne."
      Exit Sub
   End If
 
   Application.ScreenUpdating = False
 
 
   Application.DisplayAlerts = False
   Workbooks.Open Filename:="C:\Users\JULIEN\Desktop\remise de prix type.xls"
   Application.DisplayAlerts = True    
 
   Workbooks("remise de prix type.xls").Worksheets("Feuil1").Activate
 
   nb_lignes = Worksheets("Feuil1").Range("D65536").End(xlUp).Row
 
   ' Recherche de "Référence" dans la colonne 'D'
   With Worksheets("Feuil1")
       Set rfound = .Range("D1:D" & nb_lignes).Find("Référence", LookIn:=xlValues)
   End With
   ' Si trouvé
   If Not rfound Is Nothing Then
       i = rfound.Row
       i = i + 1
   End If
 
   j = i + 1
 
   Do Until Cells(j, 4).Value = "xxxx"
       Worksheets("Feuil1").Rows(j).Delete Shift:=xlUp
   Loop
 
   k = i
 
   For j = 0 To UBound(tabCellules)
           k = k + 1
           Worksheets("Feuil1").Rows(k).Insert
 
           'Rows(k).Interior.ColorIndex = xlNone
 
           With Worksheets("Feuil1")
               .Range("D" & k).Value = Workbooks("CLASSEUR CALCUL DE PRIX  2015.xls").Worksheets("PRIX").Cells(tabCellules(j), 2)
               .Range("F" & k).Value = Workbooks("CLASSEUR CALCUL DE PRIX  2015.xls").Worksheets("PRIX").Cells(tabCellules(j), 3)
               .Range("H" & k).Value = Mid(Workbooks("CLASSEUR CALCUL DE PRIX  2015.xls").Worksheets("PRIX").Cells(tabCellules(j), 8), 1, 4)
               .Range("I" & k).Value = Workbooks("CLASSEUR CALCUL DE PRIX  2015.xls").Worksheets("PRIX").Cells(tabCellules(j), 7)
               .Range("Q" & k).Value = Workbooks("CLASSEUR CALCUL DE PRIX  2015.xls").Worksheets("PRIX").Cells(tabCellules(j), 31)
               .Range("R" & k).FormulaR1C1 = "=RC[-1]*RC[-3]"
           End With
 
           With Worksheets("Feuil1").Range("E" & k & ":G" & k).Cells
                .VerticalAlignment = xlCenter
                .HorizontalAlignment = xlCenterAcrossSelection
           End With
 
           'Worksheets("Feuil1").Range("E" & k & ":G" & k).MergeCells = True
 
 
           If Workbooks("CLASSEUR CALCUL DE PRIX  2015.xls").Worksheets("PRIX").Cells(tabCellules(j), 4) = "OXY_" Then
             With Worksheets("Feuil1")
                 .Range("J" & k).Value = "Ox"
                 .Range("N" & k).Value = "Gr/Eb"
             End With
           End If
   Next j
 
   Worksheets("Feuil1").Range("R" & k + 1).FormulaLocal = "=somme(R" & i + 1 & ":R" & k & ")"
 
   Worksheets("Feuil1").Range("D" & i & ":R" & i).Copy
   Worksheets("Feuil1").Range("D" & i + 1 & ":R" & k).PasteSpecial Paste:=xlPasteFormats, Operation:=xlNone, _
        SkipBlanks:=False, Transpose:=False
   Application.CutCopyMode = False
 
   Worksheets("Feuil1").Range("D" & i - 1 & ":R" & k).Columns.AutoFit
 
   With Worksheets("Feuil1").Range("D" & i + 1 & ":R" & k)
        .Font.Bold = False
        .Interior.ColorIndex = xlNone
   End With
 
   Worksheets("Feuil1").Range("Q:R").NumberFormat = "#,##0.00 $"
 
   Application.ScreenUpdating = True

27/04/2015, 17h36
78chris

Re

As-tu vérifié en pas à pas ?

La ligne

Code:

Worksheets("Feuil1").Range("D" & i + 1 & ":R" & k).PasteSpecial Paste:=xlPasteFormats...

n'écrase-t-elle pas le format ?

Avec des noms de feuille comme Feuil1, dans 2 classeurs difficile de vérifier pour ma part...
28/04/2015, 10h49
juju05

Le recopie de la forme écrasait la fusion.