Bonjour à tous
j'utile cette macro ci dessous qui fonctionne si la cellule sélectionnée est unique
si la cellules est fusionnée cela ne marche plus.
sélection dans collone H et vérification dans collone G
Que faut il modifier pour pouvoir utiliser des cellules fusionnées ??
Merci pour votre aide
Private Sub Worksheet_BeforeDoubleClick(ByVal Target As Range, Cancel As Boolean)
On Error GoTo fin
If Not Intersect(Target, Range("H15:H25")) Is Nothing Then
If Target.Offset(0, -1) = "" Then Exit Sub
With ActiveSheet.Shapes(Target.Offset(0, -1).Text)
.Width = Application.CentimetersToPoints(Target.Value / 10)
.Top = [B18].Top
.Left = [B18].Left
.Height = 15
.TextFrame.Characters.Text = Target.Offset(0, -1).Text
End With
End If
Exit Sub
fin:
With ActiveSheet.Shapes.AddShape(msoShapePentagon, [B18].Left, [B18].Top, Application.CentimetersToPoints(Target.Value / 10), 15)
.TextFrame.Characters.Text = Target.Offset(0, -1).Text
End With
ActiveCell.Offset(0, 1).Select
End Sub
j'utile cette macro ci dessous qui fonctionne si la cellule sélectionnée est unique
si la cellules est fusionnée cela ne marche plus.
sélection dans collone H et vérification dans collone G
Que faut il modifier pour pouvoir utiliser des cellules fusionnées ??
Merci pour votre aide
Private Sub Worksheet_BeforeDoubleClick(ByVal Target As Range, Cancel As Boolean)
On Error GoTo fin
If Not Intersect(Target, Range("H15:H25")) Is Nothing Then
If Target.Offset(0, -1) = "" Then Exit Sub
With ActiveSheet.Shapes(Target.Offset(0, -1).Text)
.Width = Application.CentimetersToPoints(Target.Value / 10)
.Top = [B18].Top
.Left = [B18].Left
.Height = 15
.TextFrame.Characters.Text = Target.Offset(0, -1).Text
End With
End If
Exit Sub
fin:
With ActiveSheet.Shapes.AddShape(msoShapePentagon, [B18].Left, [B18].Top, Application.CentimetersToPoints(Target.Value / 10), 15)
.TextFrame.Characters.Text = Target.Offset(0, -1).Text
End With
ActiveCell.Offset(0, 1).Select
End Sub