VBA fonctionnant sur une seule feuille du classeur
elbaveux
Messages postés
7
Date d'inscription
Statut
Membre
Dernière intervention
-
Zoul67 Messages postés 1959 Date d'inscription Statut Membre Dernière intervention -
Zoul67 Messages postés 1959 Date d'inscription Statut Membre Dernière intervention -
Bonjour,
J'ai un code VBA qui fonctionne parfaitement dans un classeur excel mais uniquement sur la première feuille.
Ne connaissant rien au sujet, je cherche une ame bien veillante qui pourra le corriger de façon à ce que ce code fonctionne sur toutes les feuilles du classeur et cela même si on en rajoute ou efface.
Merci
T.
le code:
Option Explicit
Sub Trouvercellfusionnées()
Dim cell As Range
With ActiveSheet.UsedRange
For Each cell In .Cells
With cell
If .MergeCells = True Then
.Activate
.RowHeight = 12.75
Call AutoFitMergedCellRowHeight(cell)
End If
End With
Next cell
End With
End Sub
Sub AutoFitMergedCellRowHeight(target As Range)
'MAcro de Jim Rech
Dim CurrentRowHeight As Single, MergedCellRgWidth As Single
Dim CurrCell As Range
Dim ActiveCellWidth As Single, PossNewRowHeight As Single
If target.MergeCells Then
With target.MergeArea
.WrapText = True 'enclenche le renvoi à la ligne automatique (modif fs)
If .Rows.Count = 1 Then 'And .WrapText = True Then
Application.ScreenUpdating = False
CurrentRowHeight = .RowHeight
ActiveCellWidth = target.ColumnWidth
For Each CurrCell In target.MergeArea
MergedCellRgWidth = CurrCell.ColumnWidth + _
MergedCellRgWidth
Next
.MergeCells = False
.Cells(1).ColumnWidth = MergedCellRgWidth
.EntireRow.AutoFit
PossNewRowHeight = .RowHeight
.Cells(1).ColumnWidth = ActiveCellWidth
.MergeCells = True
.RowHeight = IIf(CurrentRowHeight > PossNewRowHeight, _
CurrentRowHeight, PossNewRowHeight)
End If
End With
End If
End Sub
Private Sub Worksheet_Change(ByVal target As Range)
If target.MergeCells Then AutoFitMergedCellRowHeight target
End Sub
J'ai un code VBA qui fonctionne parfaitement dans un classeur excel mais uniquement sur la première feuille.
Ne connaissant rien au sujet, je cherche une ame bien veillante qui pourra le corriger de façon à ce que ce code fonctionne sur toutes les feuilles du classeur et cela même si on en rajoute ou efface.
Merci
T.
le code:
Option Explicit
Sub Trouvercellfusionnées()
Dim cell As Range
With ActiveSheet.UsedRange
For Each cell In .Cells
With cell
If .MergeCells = True Then
.Activate
.RowHeight = 12.75
Call AutoFitMergedCellRowHeight(cell)
End If
End With
Next cell
End With
End Sub
Sub AutoFitMergedCellRowHeight(target As Range)
'MAcro de Jim Rech
Dim CurrentRowHeight As Single, MergedCellRgWidth As Single
Dim CurrCell As Range
Dim ActiveCellWidth As Single, PossNewRowHeight As Single
If target.MergeCells Then
With target.MergeArea
.WrapText = True 'enclenche le renvoi à la ligne automatique (modif fs)
If .Rows.Count = 1 Then 'And .WrapText = True Then
Application.ScreenUpdating = False
CurrentRowHeight = .RowHeight
ActiveCellWidth = target.ColumnWidth
For Each CurrCell In target.MergeArea
MergedCellRgWidth = CurrCell.ColumnWidth + _
MergedCellRgWidth
Next
.MergeCells = False
.Cells(1).ColumnWidth = MergedCellRgWidth
.EntireRow.AutoFit
PossNewRowHeight = .RowHeight
.Cells(1).ColumnWidth = ActiveCellWidth
.MergeCells = True
.RowHeight = IIf(CurrentRowHeight > PossNewRowHeight, _
CurrentRowHeight, PossNewRowHeight)
End If
End With
End If
End Sub
Private Sub Worksheet_Change(ByVal target As Range)
If target.MergeCells Then AutoFitMergedCellRowHeight target
End Sub
A voir également:
- VBA fonctionnant sur une seule feuille du classeur
- Comment imprimer un tableau excel sur une seule page - Guide
- Comment supprimer une feuille sur word - Guide
- Comment imprimer en a5 sur une feuille a4 - Guide
- Bruler une feuille de laurier - Guide
- Regrouper plusieurs feuilles excel en une seule - Guide
3 réponses
Bonjour,
C'est parce que ton code est associé à un unique onglet (celui qui est sélectionné dans l'arborescence à gauche quand tu vois le code).
- le code commun est à mettre dans un module (insertion > module)
- Private Sub Worksheet_Change est à adapter en le renommant Private Sub Workbook_Change et en le plaçant dans Workbook au niveau de l'arborescence.
A+
C'est parce que ton code est associé à un unique onglet (celui qui est sélectionné dans l'arborescence à gauche quand tu vois le code).
- le code commun est à mettre dans un module (insertion > module)
- Private Sub Worksheet_Change est à adapter en le renommant Private Sub Workbook_Change et en le plaçant dans Workbook au niveau de l'arborescence.
A+
Merci pour ce retour.
Ok j'ai bien réussi à faire fonctionner sur chaque feuille du classeur.
Cependant si je rajoute des feuilles je voudrais ne pas avoir à revenir sur le code ce que je suis obligé de faire avec mon fichier actuellement...
Je dois ouvrir chaque feuille dans l'arbo il lui mettre :
Private Sub Worksheet_Change(ByVal target As Range)
If target.MergeCells Then AutoFitMergedCellRowHeight target
End Sub
sinon cela ne fonctionne pas :-(
T.
Ok j'ai bien réussi à faire fonctionner sur chaque feuille du classeur.
Cependant si je rajoute des feuilles je voudrais ne pas avoir à revenir sur le code ce que je suis obligé de faire avec mon fichier actuellement...
Je dois ouvrir chaque feuille dans l'arbo il lui mettre :
Private Sub Worksheet_Change(ByVal target As Range)
If target.MergeCells Then AutoFitMergedCellRowHeight target
End Sub
sinon cela ne fonctionne pas :-(
T.
