Autres Centrer ou Annuler Centrer

[un internaute]

Bonjour le forum
Dans la macro ci-dessous lorsque le texte est trop long dans colonne B je fait Centre Texte Colonnes B - C pas de problème
Lorsqu'il est centré sur colonnes B - C le bouton devrait afficher Annuler Centrer Texte Colonnes B - C
mais n'affiche pas Annuler Centrer Texte Colonnes B - C
Il affiche Centrer Texte Colonnes B - C alors qu'il devrait afficher Annuler Centrer Texte Colonnes B - C
Idem pour F -G


PS: je ne peux pas fournir de fichier

Sub CentrerSurPlusieursColonnes()
Dim Ligne As Long, Colonne As Integer
Dim Ws As Worksheet
Dim Sh As Shape
Dim Nom As String
Dim ModeCentrage As Integer

    Application.ScreenUpdating = False
'    ActiveSheet.Unprotect
  Ligne = Selection.Row
  Colonne = Selection.Column
 
  Set Sh = ActiveSheet.Shapes(Application.Caller)
  If Sh.TopLeftCell.Address = "$I$2" Then
    If Ligne < 6 Or Ligne > 36 Or Colonne < 6 Or Colonne > 7 Then
      MsgBox ("Centrer ou Annulation Centrer Hors Zone : F6:G36")
      Exit Sub
    End If
    With Sh.TextFrame
    'On compare les 7 caractères de gauche(Left)en Majuscule(UCase)du Texte du bouton avec les caractères en Majuscule(UCase)du mot "Centrer".
      If UCase(Left(.Characters.Text, 7)) = UCase("Centrer") Then
        .Characters.Text = "Annuler Centrer Texte" & vbLf & "Colonnes F - G"
        .Characters(Start:=1, Length:=15).Font.ColorIndex = 3
        .Characters(Start:=16, Length:=16).Font.ColorIndex = 5
        .Characters(Start:=32, Length:=5).Font.ColorIndex = 3
        ModeCentrage = xlCenterAcrossSelection
        Range("G" & Ligne) = Range("F" & Ligne)
      Else
        .Characters.Text = "Centrer Texte" & vbLf & "Colonnes F - G"
        .Characters(Start:=1, Length:=7).Font.ColorIndex = 3
        .Characters(Start:=8, Length:=16).Font.ColorIndex = 5
        .Characters(Start:=24, Length:=5).Font.ColorIndex = 3
        ModeCentrage = xlCenter
        Range("G" & Ligne) = ""
      End If
    End With
    With Range("F" & Ligne & ":G" & Ligne)
       .HorizontalAlignment = ModeCentrage
       .VerticalAlignment = xlCenter
    End With
  Else
    If Ligne < 6 Or Ligne > 36 Or Colonne < 2 Or Colonne > 3 Then
      MsgBox ("Centrer ou Annulation Centrer Hors Zone : B6:C36")
      Exit Sub
    End If
 
    If Range("B" & Ligne) = "" Or Ligne > Range("A" & Rows.Count).End(xlUp).Row Or Ligne < 5 Then
      Ligne = Range("A" & Rows.Count).End(xlUp).Row
    End If
      With Sh.TextFrame
      'On compare les 7 caractères de gauche(Left)en Majuscule(UCase)du Texte du bouton avec les caractères en Majuscule(UCase)du mot "Centrer".
        If UCase(Left(.Characters.Text, 7)) = UCase("Centrer") Then
        .Characters.Text = "Annuler Centrer Texte" & vbLf & "Colonnes B - C"
        .Characters(Start:=1, Length:=15).Font.ColorIndex = 3
        .Characters(Start:=16, Length:=16).Font.ColorIndex = 5
        .Characters(Start:=32, Length:=5).Font.ColorIndex = 3
          ModeCentrage = xlCenterAcrossSelection
        Else
        .Characters.Text = "Centrer Texte" & vbLf & "Colonnes B - C"
        .Characters(Start:=1, Length:=7).Font.ColorIndex = 3
        .Characters(Start:=8, Length:=16).Font.ColorIndex = 5
        .Characters(Start:=24, Length:=5).Font.ColorIndex = 3
        ModeCentrage = xlCenter
          ModeCentrage = xlCenter
 
        End If
      End With
 
        'Calcul de la dernière ligne.Celle-ci sera automatiquement centrée sur les colonnes B & C en cliquant sur le Bouton Centrer Texte Sur Plusieurs Colonnes
 
      With Range("B" & Ligne & ":C" & Ligne)
         .HorizontalAlignment = ModeCentrage
         .VerticalAlignment = xlCenter
      End With
    End If
'    ActiveSheet.Protect
End Sub

 

[fanch55]

Salut,
D'après l'analyse succincte du code :
Si la cellule sélectionnée fait partie des plages B6-C36 ou F6-G36, on centre la cellule sélectionnée si elle ne l'est pas ou on annule tout alignement si elle est centrée ...
Comme aucunes cellules ne sont fusionnées, la sub devrait plutôt s'appeler CentrerCellule ...

Ai-je bon ?

 

[patricktoulon]

Bonjour
juste en passant
là encore une fois même si dans la demande il est précisé qu'il y a impossibilité de fournir un fichier
il aurait été bien utile surtout qu'en deux coup de cuillère a pot le demandeur aurai pu faire un fichier exemple

pourquoi il aurait été utile:
et bien tout simplement par ce je ne suis pas sur que la condition ci dessous soit celle que tu souhaite

 If Ligne < 6 Or Ligne > 36 Or Colonne < 6 Or Colonne > 7 Then

en effet les deux 2d (en l’occurrence pour les colonnes) vont à l'encontre des deux premières
que va t il se passer selon toi si nous somme sur la ligne 8 par exemple et la colonne 4

les additions logiques(and /or / xor) ça peut être un vrai casse tête quand on maitrise pas
surtout dans le cadre d'abssice et ordonnée

à méditer
tiens allez teste ça

Sub test()
   Dim Ligne& , Colonne&
 Ligne = 8
    Colonne = 4
    If Ligne < 6 Or Ligne > 36 Or Colonne < 6 Or Colonne > 7 Then
        MsgBox "Et!!...OUAIP!!!! on passe c'est baloh!!! hein !!!"
    End If
End Sub

 

[patricktoulon]

allez après je laisse la main à @fanch55
la condition que tu souhaite c'est
si ligne <6 ou >36 ET!!!! colonne<6 ou colonne >7
pour faire celà tu ne peut pas l'ecrire comme ca

If Ligne < 6 Or Ligne > 36 and Colonne < 6 Or Colonne > 7 Then

car là encore le and (pour colonne) va contredire la condition ligne
on l'ecrira plutot comme ça

If (Ligne < 6 Or Ligne > 36) and (Colonne < 6 Or Colonne > 7Then)

là oui je te garantie que ca fera le job
test d'exemple
change les valeur de ligne et colonne

Sub test()
    Ligne = 4
    Colonne = 6
    If (Ligne < 6 Or Ligne > 36) And (Colonne < 6 Or Colonne > 7) Then
        MsgBox "Et Bien sur que là on passe "
    Else
    MsgBox "mais bien sur!!! que non que l'on passe pas!!! "
    End If

End Sub

bonne continuation

 

[un internaute]

Bonsoir fanch55
Pour être plus explicite
Je tape du texte dans n'importe quelle cellule par exemple B6
Le texte est trop long je suis obligé de cliquer sur

Il est centré sur les 2 colonnes
J'enregistre
Si le texte contient colonne B je ne fait rien
Ensuite si je reviens par exemple sur B6 ça n'affiche pas

Ça affiche

Si je viens sur cellule B7 par exemple et que le texte contient dans colonne B
Ça ne met pas ou des fois oui mais pas systématique

mais

 

[fanch55]

Testez le classeur ci-joint:
sélectionnez une cellule dans les zones encadrées B6-C36 ou F6-G36

 

[patricktoulon]

re
tiens voila mon exemple
j'attire ton attention sur le module de la feuille
la détection se fait au selection_change et au change de l'alignement

 

[fanch55]

re
tiens voila mon exemple
j'attire ton attention sur le module de la feuille
la détection se fait au selection_change et au change de l'alignement

Salut Pat,
Tu rejoins à peu près le code que j'ai fait , sauf que ta proposition ne donne plus accès en saisie aux colonnes c6:c36 et g6:g36

 

[patricktoulon]

re
oui ça al'air pas mal
par contre il n'y a pas une erreur en B8 tu centre sur A:B???

 

[fanch55]

re
oui ça al'air pas mal
par contre il n'y a pas une erreur en B8 tu centre sur A:B???

Non, non , le texte déborde de B8 quand il n'est pas centré sur B-C ....

 

[un internaute]

Bonjour le forum
Avec toutes mes excuses pour le retard
Mais vous ne pouviez pas arriver à faire ce que je voulais sans fichier et de plus j'ai changé de stratégie

Voici la macro

Private Sub Workbook_SheetSelectionChange(ByVal Sh As Object, ByVal Target As Range)
Dim Obj As Shape, Ligne As Long
Dim ColRef As String
Dim ColDep As String, ColsUtiles As String
                                                      ' Change automatiquement le texte du bouton
  Ligne = Selection.Row
 
    If UCase(Sh.Name) = "MENU" And Target.Count > 1 Then Exit Sub
    
    Application.ScreenUpdating = False
    If Target.Column = 2 Then
      ColRef = "A1"
      ColDep = "B"
      ColsUtiles = "Colonnes B - C"
    ElseIf Target.Column = 6 Then
      ColRef = "I2"
      ColDep = "F"
      ColsUtiles = "Colonnes F - G"
    Else
      Exit Sub
    End If
      
'      ActiveSheet.Unprotect

    For Each Obj In ActiveSheet.Shapes
      If InStr(1, Obj.TextFrame.Characters.Text, "Centrer Texte", vbTextCompare) > 0 And Obj.TopLeftCell.Address(0, 0) = ColRef Then Exit For
    Next Obj

    If Not Obj Is Nothing Then
    ' Calcul de la dernière ligne.Celle-ci sera automatiquement centrée sur les colonnes B & C en cliquant sur le Bouton Centrer Texte Sur Plusieurs Colonnes

      With Obj.TextFrame
        If Range(ColDep & Ligne).HorizontalAlignment = xlCenterAcrossSelection Then
          .Characters.Text = "Annuler Centrer Texte" & vbLf & ColsUtiles
        .Characters(Start:=1, Length:=15).Font.ColorIndex = 3
        .Characters(Start:=16, Length:=16).Font.ColorIndex = 5
        .Characters(Start:=32, Length:=5).Font.ColorIndex = 3
          '.Characters(Start:=23, Length:=22).Font.ColorIndex = 5
        Else
          .Characters.Text = "Centrer Texte" & vbLf & ColsUtiles
        .Characters(Start:=1, Length:=7).Font.ColorIndex = 3
        .Characters(Start:=8, Length:=16).Font.ColorIndex = 5
        .Characters(Start:=24, Length:=5).Font.ColorIndex = 3
          '.Characters(Start:=15, Length:=22).Font.ColorIndex = 5
        End If
      End With
    End If
End Sub

Je renouvelle encore mes excuses mais vos exemples je suis preneur
Cordialement

 

[fanch55]

Mais vous ne pouviez pas arriver à faire ce que je voulais sans fichier et de plus j'ai changé de stratégie

La macro fournie ne centre ou ne décentre rien, elle semble incomplète .
Le code ci-dessous tente de se coller au plus près du code fourni et devrait pouvoir la remplacer.
Associez la Macro Align_Cell aux shapes concernés .

Private Sub Workbook_SheetSelectionChange(ByVal Sh As Object, ByVal Target As Range)
    Dim Dwo As Object, Shp As Object, Cible As String
    For Each Shp In Sh.DrawingObjects
        If Shp.TopLeftCell.Address = "$A$1" _
        Or Shp.TopLeftCell.Address = "$I$2" _
        Then Shp.Visible = False
    Next
    Select Case True
    Case Target.Count > 1
    Case UCase(Sh.Name) = "MENU"
    Case Not Intersect(Target, Union([B:C], [F:G])) Is Nothing
        For Each Shp In Sh.DrawingObjects
            Select Case True
            Case Shp.TopLeftCell.Address = "$A$1" _
             And Not Intersect(Target, [B:C]) Is Nothing
                Set Dwo = Shp
                Cible = vbLf & "Colonnes B-C"
                Exit For
            Case Shp.TopLeftCell.Address = "$I$2" _
             And Not Intersect(Target, [F:G]) Is Nothing
                Set Dwo = Shp
                Cible = vbLf & "Colonnes F-G"
                Exit For
            End Select
        Next
        If Not Dwo Is Nothing Then
            With Dwo
                .Visible = True
                .Font.ColorIndex = 5
                .Text = IIf(Target.HorizontalAlignment = xlCenterAcrossSelection, _
                            "Annuler Centrer Texte", _
                            "Centrer Texte") & Cible
                .Characters(Start:=1, Length:=InStr(.Text, " Texte")).Font.ColorIndex = 3
                .Characters(Start:=InStr(.Text, "s") + 1).Font.ColorIndex = 3
            End With
        End If
    End Select
End Sub
Sub Align_Cell()
    Dim Target As Range
    With Selection
        Select Case .Column
            Case Columns("B").Column, Columns("F").Column:  Set Target = .Resize(, 2)
            Case Columns("C").Column, Columns("G").Column:  Set Target = .Offset(, -1).Resize(, 2)
        End Select
        With Target
            If .Cells(1) = "" Then .Cells(1) = .Cells(2): .Cells(2) = ""
            .HorizontalAlignment = IIf(.HorizontalAlignment = xlCenterAcrossSelection, xlCenter, xlCenterAcrossSelection)
            .VerticalAlignment = xlCenter
        End With
        Workbook_SheetSelectionChange ActiveSheet, .Cells(1)
    End With
    Application.EnableEvents = True
End Sub

Je vous signale toutefois que mettre le code dans le Thisworkbook implique que le code concerne toutes les feuilles ( sauf Menu ) ....

 

[un internaute]

Bonjour fanch55
Oui c'est bien ça
Merci à toi
Bonne journée