Bonjour,
Les fonctions de Fusion de cellules du Ruban (Fusionner et Centrer, Fusionner) ne conservent que le contenu et la police de la 1ère cellule de la plage de cellules à fusionner.
Si l'on souhaite fusionner des cellules en conservant tout le contenu et la police de chaque cellule, la tâche peut devenir pénible si la police du contenu de chaque cellule (Nom, Taille, Couleur, Gras, Italique, Souligné, Exposant) n'est pas homogène :
Le Copier-Coller dans Excel entraine quelques surprises : Le Texte Collé depuis le Presse-Papier à l'intérieur du Texte d'une cellule dont la Police est hétérogène se retrouve avec la Police du 1er caractère situé à gauche du texte copié
Le Rechercher - Remplacer également : Tout le contenu de la cellule est affecté avec une police unique (Calibri 12 Normal, Noir dans mon Excel)
D'où l'idée de la création de ce groupe de macros :
Pour Fusionner une Plage de Cellules
Pour Fractionner une Cellule
Le Code (mis à jour le 16/01 à 19h30)
Remarques
La fusion et le Fractionnement est instantané (si on conserve uniquement le contenu). Il est un peu lent si on conserve également la Police (traitement caractère par caractère). J'ai pu constater une lenteur anormale en modifiant la police d'une partie du contenu d'une cellule par les boutons du Groupe Police du Ruban.
Ajout des macros dans le ruban
Si vous souhaitez intégrer ces macros dans un de vos fichiers de macros complémentaires, et les avoir disponibles dans le ruban, Exportez vos personnalisations de Ruban, intégrer ces lignes dans le fichier d'export, remplacer "NomCompletFichierMacros" dans les lignes onaction par votre fichier de macros complémentaires et Importer le fichier de personnalisation du Ruban ainsi modifié.
Les fonctions de Fusion de cellules du Ruban (Fusionner et Centrer, Fusionner) ne conservent que le contenu et la police de la 1ère cellule de la plage de cellules à fusionner.
Si l'on souhaite fusionner des cellules en conservant tout le contenu et la police de chaque cellule, la tâche peut devenir pénible si la police du contenu de chaque cellule (Nom, Taille, Couleur, Gras, Italique, Souligné, Exposant) n'est pas homogène :
Le Copier-Coller dans Excel entraine quelques surprises : Le Texte Collé depuis le Presse-Papier à l'intérieur du Texte d'une cellule dont la Police est hétérogène se retrouve avec la Police du 1er caractère situé à gauche du texte copié
Le Rechercher - Remplacer également : Tout le contenu de la cellule est affecté avec une police unique (Calibri 12 Normal, Noir dans mon Excel)
D'où l'idée de la création de ce groupe de macros :
- FusionnerCellulesConserverFormat qui permet de fusionner une plage de cellules en conservant, pour chaque cellule à fusionner
- le contenu
- la police (Nom, Taille, Couleur, Gras, Italique, Souligné, Exposant), de chaque caractère
- FusionnerCellulesSansConserverFormat qui permet de fusionner une plage de cellules en conservant, pour chaque cellule à fusionner
- le contenu uniquement
- FractionnerCelluleConserverFormat qui permet de fractionner une cellule en x lignes, en conservant, pour chaque cellule issue du fractionnement
- la police (Nom, Taille, Couleur, Gras, Italique, Souligné, Exposant), de chaque caractère de la cellule fractionnée
- FractionnerCellulesSansConserverFormat qui permet de fractionner une cellule en x lignes, sans conserver, pour chaque cellule issue du fractionnement la police de la cellule fractionnée
Pour Fusionner une Plage de Cellules
- Sélectionner une plage de cellules contigües (x lignes y colonnes)
- Activer la macro FusionnerCellulesConserverFormat ou FusionnerCellulesSansConserverFormat (Bouton du Ruban ...)
- La plage sélectionnée est fusionnée sur la 1ère cellule e la plage :
- le contenu de chaque colonne d'origine est séparé par un Espace,
- le contenu de chaque ligne d'origine est séparé par un Saut de Ligne
- Le format de police de chaque caractère des cellules d'origine (Nom, Taille, Couleur, Gras, Italique, Souligné, Exposant) est conservé ou non selon la macro exécutée
Pour Fractionner une Cellule
- Sélectionner une cellule (fusionnée ou non)
- Activer la macro FractionnerCelluleConserverFormat ou FractionnerCelluleSansConserverFormat (Bouton du Ruban ...)
- Le contenu de la cellule est fractionnée (une plage de x lignes y colonnes)
- le découpage en lignes correspond aux sauts de ligne de la cellule sélectionnée
- le découpage en colonnes est opéré (sur le principe des fichiers csv) à l'aide d'un délimitateur, le caractère µ, rarement utilisé, à ajouter dans le texte de la cellule à fractionner, à chaque changement de colonne souhaité (le délimitateur sera supprimé après le traitement).
- Le format de police de chaque caractère (Nom, Taille, Couleur, Gras, Italique, Souligné, Exposant) est conservé ou non selon la macro exécutée
Le Code (mis à jour le 16/01 à 19h30)
VB:
Option Explicit
'Un groupe de macros :
'- FusionnerCellulesConserverFormat qui permet de fusionner une plage de cellules en conservant,
' pour chaque cellule à fusionner
' - le contenu
' - la police (Nom, Taille, Couleur, Gras, Italique, Souligné, Exposant), de chaque caractère
'- FusionnerCellulesSansConserverFormat qui permet de fusionner une plage de cellules en conservant,
' pour chaque cellule à fusionner
' - le contenu uniquement
'- FractionnerCelluleConserverFormat qui permet de fractionner une cellule en x lignes, en conservant,
' pour chaque cellule issue du fractionnement
' - la police (Nom, Taille, Couleur, Gras, Italique, Souligné, Exposant), de chaque caractère de la cellule fractionnée
'- FractionnerCellulesSansConserverFormat qui permet de fractionner une cellule en x lignes, sans conserver,
' pour chaque cellule issue du fractionnement la police de la cellule fractionnée
Sub FusionnerCellulesConserverFormat()
Dim start
start = Time
FusionnerCellules True
'Debug.Print "Durée FusionnerCellulesConserverFormat (secondes) : " & Round((Time - start) * 24 * 60 * 60)
End Sub
Sub FusionnerCellulesSansConserverFormat()
Dim start
start = Time
FusionnerCellules False
'Debug.Print "Durée FusionnerCellulesSansConserverFormat (secondes) : " & Round((Time - start) * 24 * 60 * 60)
End Sub
Sub FractionnerCelluleConserverFormat()
Dim start
start = Time
FractionnerCelluleFusionnee True
'Debug.Print "Durée FractionnerCelluleConserverFormat (secondes) : " & Round((Time - start) * 24 * 60 * 60)
End Sub
Sub FractionnerCelluleSansConserverFormat()
FractionnerCelluleFusionnee False
End Sub
Sub FusionnerCellules(Optional pConserverFormat As Boolean = True)
' Les cellules de La sélection sont fusionnées sur la 1ère cellule
' Le format de police de chaque caractère des cellules d'origine (Nom, Taille, Couleur, Gras, Italique, Souligné, Exposant)
' est conservé ou non en fonction du paramètre pConserverFormat
' Après Fusion, le contenu de chaque colonne d'origine est séparé par un Espace,
' le contenu de chaque ligne d'origine est séparé par un Saut de Ligne
Dim Titre As String
Dim Message As String
Dim Reponse
Dim i As Long, j As Long
Dim PosDeb As Long
Dim CelluleS As Range
Dim CelluleI As Range
Dim CelluleO As Range
Dim CelluleW As Range
Dim MemoHeightSelection As Double
Titre = "Fusion des cellules de la sélection"
If Not (TypeOf Selection Is Range) Then
MsgBox "Aucune Cellule sélectionnée", vbCritical, Titre
Exit Sub
End If
If Selection.Areas.Count > 1 Then
MsgBox "La sélection doit être composée de cellules contigües !", vbCritical, Titre
Exit Sub
End If
If Selection.MergeCells Then
MsgBox "La sélection doit être composée de cellules non fusionnées !", vbCritical, Titre
Exit Sub
End If
For Each CelluleI In Selection
If WorksheetFunction.IsFormula(CelluleI) Then
i = i + 1
Message = Message & " - " & CelluleI.Address
End If
Next CelluleI
If i > 0 Then
Reponse = MsgBox( _
i & " cellules de la sélection sont des formules." & vbLf _
& "(" & Message & ")" & vbLf _
& "Elles seront remplacées par leur valeur.", _
vbOKCancel, Titre)
If Reponse <> vbOK Then Exit Sub
End If
Application.ScreenUpdating = False
' Etape 1
'---------
' - Copie Dans la plage intermédiaire CelluleW
Set CelluleW = ActiveSheet.Cells(ActiveSheet.Rows.Count, ActiveSheet.Columns.Count).Offset(1 - Selection.Rows.Count, 1 - Selection.Columns.Count)
Set CelluleO = CelluleW
Selection.Copy Destination:=CelluleO
Etape2:
' Etape 2
'---------
'- Copie sans Mise en Forme dans la 1ère cellule de la sélection
MemoHeightSelection = Selection.Cells(1, 1).Height
Selection.ClearContents
PosDeb = 0
Set CelluleO = Selection.Cells(1, 1)
For Each CelluleS In Selection
i = CelluleS.Row - Selection.Row
j = CelluleS.Column - Selection.Column
Set CelluleI = CelluleW.Offset(CelluleS.Row - Selection.Row, CelluleS.Column - Selection.Column)
Select Case True
Case CelluleS.Row = Selection.Row And CelluleS.Column = Selection.Column
CelluleO.Value = CelluleI.Value
Case CelluleS.Column = Selection.Column
CelluleO.Value = CelluleO.Value & vbLf & CelluleI.Value
Case Else
CelluleO.Value = CelluleO.Value & " " & CelluleI.Value
End Select
PosDeb = PosDeb + Len(CelluleI.Value) + 1 ' à cause du VbLf
Next CelluleS
Selection.Cells(1, 1).EntireRow.RowHeight = MemoHeightSelection
Etape3:
If Not pConserverFormat Then GoTo Fusion
' Etape 3
'---------
'- Mise en forme dans la cellule de fusion
' Ligne par Ligne
' - chaque colonne séparée par un espace
' - chaque ligne séparée par un saut de ligne
PosDeb = 0
Set CelluleO = Selection.Cells(1, 1)
For Each CelluleS In Selection
i = CelluleS.Row - Selection.Row
j = CelluleS.Column - Selection.Column
Set CelluleI = CelluleW.Offset(CelluleS.Row - Selection.Row, CelluleS.Column - Selection.Column)
CopiePoliceFusion CelluleI, Selection.Cells(1, 1), PosDeb
PosDeb = PosDeb + Len(CelluleI.Value) + 1 ' à cause du VbLf
Next CelluleS
Fusion:
' Fusion
Selection.HorizontalAlignment = xlCenter
Selection.VerticalAlignment = xlCenter
Selection.Merge
Set CelluleW = CelluleW.Resize(Selection.Rows.Count)
CelluleW.EntireRow.Delete
Application.ScreenUpdating = True
Set CelluleI = Nothing
Set CelluleO = Nothing
Set CelluleW = Nothing
End Sub
Sub FractionnerCelluleFusionnee(Optional pConserverFormat As Boolean = True)
' La cellule(fusionnée ou non) sélectionnée est fractionnée ,la Fusion est annulée
' Le contenu de la cellule est fractionnée (une plage de x lignes y colonnes)
' le découpage en lignes correspond aux sauts de ligne de la cellule sélectionnée
' le découpage en colonnes est opéré (sur le principe des fichiers csv)
' à l'aide d'un délimitateur, le caractère µ, rarement utilisé, à ajouter dans le texte de la cellule à fractionner,
' à chaque changement de colonne souhaité (le délimitateur sera supprimé après le traitement).
' Le format de police de chaque caractère (Nom, Taille, Couleur, Gras, Italique, Souligné, Exposant)
' est conservé ou non en fonction du paramètre pConserverFormat
Const SEP = "µ"
Dim i As Integer, j As Integer, PosDeb As Long
Dim NbLig As Integer, NbCol As Integer
Dim CelluleI As Range
Dim CelluleO As Range
Dim CelluleW As Range
Dim TabLignes As Variant, TabColonnes As Variant
Dim Titre As String
Titre = "Fractionner la Cellule (fusionnée ou non) en plusieurs lignes"
If Not (TypeOf Selection Is Range) Then
MsgBox "Aucune Cellule sélectionnée", vbCritical, Titre
Exit Sub
End If
If Selection.Count > 1 And Not Selection.MergeCells Then
MsgBox "La sélection doit comporter une seule cellule ou doit être une fusion de cellules !", vbCritical, Titre
Exit Sub
End If
If Selection.Areas.Count > 1 Then
MsgBox "La sélection doit être composée de cellules contigües !", vbCritical, Titre
Exit Sub
End If
Application.ScreenUpdating = False
If Selection.MergeCells Then
Selection.UnMerge
End If
' Compter le nombre de lignes et colonnes issues du fractionnement
Set CelluleI = Selection.Cells(1, 1)
TabLignes = Split(CelluleI, vbLf)
NbLig = UBound(TabLignes) - LBound(TabLignes) + 1
NbCol = 1
For i = LBound(TabLignes) To UBound(TabLignes)
TabColonnes = Split(TabLignes(i), SEP)
NbCol = Application.Max(NbCol, UBound(TabColonnes) - LBound(TabColonnes) + 1)
Next i
Set CelluleW = ActiveSheet.Cells(ActiveSheet.Rows.Count, ActiveSheet.Columns.Count).Offset(1 - Selection.Rows.Count, 1 - Selection.Columns.Count)
' Etape 1
'---------
' - Copie avec mise en forme dans la cellule intermédiaire CelluleW
Set CelluleI = Selection.Cells(1, 1)
Set CelluleO = CelluleW
CelluleI.Copy Destination:=CelluleO
PosDeb = 0
Etape2:
' Etape 2
'---------
'- Copie avec ou sans Mise en Forme
Selection.ClearContents
PosDeb = 0
Set CelluleI = CelluleW
PosDeb = 0
For i = LBound(TabLignes) To UBound(TabLignes)
TabColonnes = Split(TabLignes(i), SEP)
For j = LBound(TabColonnes) To UBound(TabColonnes)
Set CelluleO = Selection(1, 1).Offset(i, j)
CelluleO.Value = TabColonnes(j)
If pConserverFormat Then CopiePoliceFractionnerCellule CelluleI, CelluleO, PosDeb
PosDeb = PosDeb + Len(TabColonnes(j)) + 1
Next j
Next i
CelluleW.ClearContents
CelluleW.EntireRow.Delete
Application.ScreenUpdating = True
Set CelluleI = Nothing
Set CelluleO = Nothing
Set CelluleW = Nothing
End Sub
Public Sub CopiePoliceFusion(pCelluleI As Range, pCelluleO As Range, pPosDeb As Long)
Dim i As Integer
For i = 1 To Len(pCelluleI.Value) + 1
pCelluleO.Characters(pPosDeb + i, 1).Font.Bold = pCelluleI.Characters(i, 1).Font.Bold
pCelluleO.Characters(pPosDeb + i, 1).Font.Color = pCelluleI.Characters(i, 1).Font.Color
pCelluleO.Characters(pPosDeb + i, 1).Font.Strikethrough = pCelluleI.Characters(i, 1).Font.Strikethrough
' La ligne Superscript (exposant) doit être placée avant la ligne Subscript (indice) sinon pas de mise à indice
'--------------------------------------------------------------------------------------------------------------
pCelluleO.Characters(pPosDeb + i, 1).Font.Superscript = pCelluleI.Characters(i, 1).Font.Superscript
pCelluleO.Characters(pPosDeb + i, 1).Font.Subscript = pCelluleI.Characters(i, 1).Font.Subscript
pCelluleO.Characters(pPosDeb + i, 1).Font.FontStyle = pCelluleI.Characters(i, 1).Font.FontStyle
pCelluleO.Characters(pPosDeb + i, 1).Font.Italic = pCelluleI.Characters(i, 1).Font.Italic
pCelluleO.Characters(pPosDeb + i, 1).Font.Underline = pCelluleI.Characters(i, 1).Font.Underline
pCelluleO.Characters(pPosDeb + i, 1).Font.Size = pCelluleI.Characters(i, 1).Font.Size
pCelluleO.Characters(pPosDeb + i, 1).Font.Name = pCelluleI.Characters(i, 1).Font.Name
Next i
End Sub
Sub CopiePoliceFractionnerCellule(pCelluleI As Range, pCelluleO As Range, pPosDeb As Long)
Dim i As Integer
For i = 1 To Len(pCelluleO.Value) + 1
pCelluleO.Characters(i, 1).Font.Bold = pCelluleI.Characters(pPosDeb + i, 1).Font.Bold
pCelluleO.Characters(i, 1).Font.Color = pCelluleI.Characters(pPosDeb + i, 1).Font.Color
pCelluleO.Characters(i, 1).Font.Strikethrough = pCelluleI.Characters(pPosDeb + i, 1).Font.Strikethrough
' La ligne Superscript (exposant) doit être placée avant la ligne Subscript (indice) sinon pas de mise à indice
'--------------------------------------------------------------------------------------------------------------
pCelluleO.Characters(i, 1).Font.Superscript = pCelluleI.Characters(pPosDeb + i, 1).Font.Superscript
pCelluleO.Characters(i, 1).Font.Subscript = pCelluleI.Characters(pPosDeb + i, 1).Font.Subscript
pCelluleO.Characters(i, 1).Font.FontStyle = pCelluleI.Characters(pPosDeb + i, 1).Font.FontStyle
pCelluleO.Characters(i, 1).Font.Italic = pCelluleI.Characters(pPosDeb + i, 1).Font.Italic
pCelluleO.Characters(i, 1).Font.Underline = pCelluleI.Characters(pPosDeb + i, 1).Font.Underline
pCelluleO.Characters(i, 1).Font.Size = pCelluleI.Characters(pPosDeb + i, 1).Font.Size
pCelluleO.Characters(i, 1).Font.Name = pCelluleI.Characters(pPosDeb + i, 1).Font.Name
Next i
End SubRemarques
La fusion et le Fractionnement est instantané (si on conserve uniquement le contenu). Il est un peu lent si on conserve également la Police (traitement caractère par caractère). J'ai pu constater une lenteur anormale en modifiant la police d'une partie du contenu d'une cellule par les boutons du Groupe Police du Ruban.
Ajout des macros dans le ruban
Si vous souhaitez intégrer ces macros dans un de vos fichiers de macros complémentaires, et les avoir disponibles dans le ruban, Exportez vos personnalisations de Ruban, intégrer ces lignes dans le fichier d'export, remplacer "NomCompletFichierMacros" dans les lignes onaction par votre fichier de macros complémentaires et Importer le fichier de personnalisation du Ruban ainsi modifié.
Code:
<!-- Groupe Fusionner ou Fractionner -->
<mso:group id="mso_c1.-71D0D905" label="" insertBeforeQ="mso:GroupNumber" autoScale="true">
<!-- Menu Fusionner ou Fractionner -->
<mso:menu id="MenuFusionnerFractionner"
screentip="Fusionner ou Fractionner"
supertip="Fusionner ou Fractionner les cellules sélectionnées (en conservant leur contenu et éventuellement la Police)"
itemSize="normal"
imageMso="MergeCenter" >
<mso:button id="Bouton_Fusionner_Conserver"
label="Fusionner (Conserver la Police)"
supertip="Fusionner les cellules sélectionnées (en conservant contenu et Police)"
imageMso="MergeCenter"
onAction="NomCompletFichierMacros!FusionnerCellulesConserverFormat"
visible="true"/>
<mso:button id="Bouton_Fusionner_Sans_Conserver"
label="Fusionner ((Sans Conserver la Police)"
supertip="Fusionner les cellules sélectionnées (en conservant uniquement le contenu)"
imageMso="MergeCenter"
onAction="NomCompletFichierMacros!FusionnerCellulesSansConserverFormat"
visible="true"/>
<mso:button id="Bouton_Fractionner_Conserver"
label="Fractionner (Conserver la Police)"
supertip="Fractionner la cellule en Lignes et Colonnes (en conservant contenu et Police) - Caractère µ pour Changer de Colonne - Saut de Ligne pour Changer de Ligne"
imageMso="UnmergeCells"
onAction="NomCompletFichierMacros!FractionnerCelluleConserverFormat"
visible="true"/>
<mso:button id="Bouton_Fractionner_Sans_Conserver"
supertip="Fractionner la cellule en Lignes et Colonnes (en conservant uniquement le contenu) - Caractère µ pour Changer de Colonne - Saut de Ligne pour Changer de Ligne"
label="Fractionner (Sans Conserver la Police)"
imageMso="UnmergeCells"
onAction="NomCompletFichierMacros!FractionnerCelluleSansConserverFormat"
visible="true"/>
</mso:menu>
</mso:group>
Dernière édition:
