erreur avec cellules fusionnées

[jtitin]

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

 

[jtitin]

Re : erreur avec cellules fusionnées

Re bonjour à tous
avec un fichier joint cela sera plus compréhensible
le problème est que je ne peu pas passé outre les cellules fusionnées
ci joint mon fichier exemple

merci pour votre aide

 

[Dranreb]

Re : erreur avec cellules fusionnées

Bonjour
Esayez en mettant devant :

Set Target = Target(1, 1) ' 1ère cellule de la sélection

À +

 

[jtitin]

Re : erreur avec cellules fusionnées

Merci pour ta réponse mais cela ne fonctione toujours pas

 

[Dranreb]

Re : erreur avec cellules fusionnées

Oui c'était un peu plus compliqué :

Private Sub Worksheet_BeforeDoubleClick(ByVal Target As Range, Cancel As Boolean)
Dim NomSh As String, Sh As Shape
Set Target = Intersect(Target, Range("V7:V21"))
If Target Is Nothing Then Exit Sub
NomSh = Target.Offset(0, -1).MergeArea(1, 1).Value
If NomSh = "" Then Exit Sub
On Error Resume Next
Set Sh = ActiveSheet.Shapes(NomSh)
If Err Then
   Set Sh = ActiveSheet.Shapes.AddShape(msoShapePentagon, Me.[B6].Left, Me.[B6].Top, Application.CentimetersToPoints(Target.Value / 10), 15)
   Sh.Name = NomSh
   End If
Sh.Width = Application.CentimetersToPoints(Target.Value / 10)
Sh.Top = [B6].Top
Sh.Left = [B6].Left
Sh.Height = 15
Sh.TextFrame.Characters.Text = NomSh
Cancel = True
End Sub

Cordialement.

 

[jtitin]

Re : erreur avec cellules fusionnées

Merci Dranreb
je viens de tester c'est OK

maintenant je vais essayer de comprendre
merci encore

 

[jtitin]

Re : erreur avec cellules fusionnées

de nouveau de retour
cela marche comme je souhaite mais il y a un problème dans le fonctionnement
si une forme est déja présente et que je fais un double clic pour l'avoir de nouveau la 1er s'efface et est remplacé
je souhaite pouvoir les conserver et en ajouter

merci encore

 

[Dranreb]

Re : erreur avec cellules fusionnées

Elle est recouverte si celle ajoutée est plus longue, non ?
Chez moi aucune forme existante n'est effacée...

 

[jtitin]

Re : erreur avec cellules fusionnées

non la forme une fois créer je la déplace
ensuite je reclic pour obtenir la même forme
la 1er est suprimer et est recréer en B6
il faudrait que la forme déplacée reste et une nouvelle vienne en B6 pour être déplacée

 

[Dranreb]

Re : erreur avec cellules fusionnées

Bon alors comme ça :

Private Sub Worksheet_BeforeDoubleClick(ByVal Target As Range, Cancel As Boolean)
Dim NomSh As String, Sh As Shape
Set Target = Intersect(Target, Range("V7:V21"))
If Target Is Nothing Then Exit Sub
NomSh = Target.Offset(0, -1).MergeArea(1, 1).Value
If NomSh = "" Then Exit Sub
Set Sh = ActiveSheet.Shapes.AddShape(msoShapePentagon, Me.[B6].Left, Me.[B6].Top, Application.CentimetersToPoints(Target.Value / 10), 15)
Sh.TextFrame.Characters.Text = NomSh
Cancel = True
End Sub

 

[jtitin]

Re : erreur avec cellules fusionnées

Merci Dranreb
tout est OK