XL 2016 compter le nombre de cellules sous un rectangle

vgendron à dit:

Hello

je ne comprend pas bien ce que tu veux compter; le nombre de cellules selectionnées pour faire ton rectangle?
dans ce cas
1) dans le code de la feuille 1

VB:

Private Sub Worksheet_SelectionChange(ByVal Target As Range)
    If Not Intersect(Target, Me.Range("C:DB")) Is Nothing Then
        UserForm1.Show
    End If
End Sub

2) dans le code du USF

VB:

Private Sub UserForm_Initialize()
    Me.TextBox1.Value = Selection.Cells.Count
End Sub

Private Sub CommandButton1_Click()
    Dim info As String
    info = Me.TextBox1.Value
  
    ' Fermer l'UserForm
    Me.Hide
  
    ' Afficher l'information dans un rectangle
    Dim rng As Range
    Set rng = Selection
  
    Dim ws As Worksheet
    Set ws = rng.Worksheet
  
    Dim rectLeft As Double
    Dim rectTop As Double
    Dim rectWidth As Double
    Dim rectHeight As Double
  
    rectLeft = rng.Left
    rectTop = rng.Top
    rectWidth = rng.Width
    rectHeight = rng.Height
  
    Dim rect As Shape
    Set rect = ws.Shapes.AddShape(msoShapeRoundedRectangle, rectLeft, rectTop, rectWidth, rectHeight)
  
    With rect
        .LockAspectRatio = msoFalse
        .TextFrame.Characters.Text = info
        .TextFrame.HorizontalAlignment = xlCenter
        .TextFrame.VerticalAlignment = xlCenter
        .TextFrame.Characters.Font.Size = 12
        .Fill.Transparency = 0.3
    End With
    Unload Me
End Sub

Cliquez pour agrandir...

mapomme à dit:

Bonjour à tous ,

Double-cliquer sur la cellule A1 en jaune.
Le code dans le module de la feuille "Feuil1" :

VB:

Private Sub Worksheet_BeforeDoubleClick(ByVal Target As Range, Cancel As Boolean)
Dim shp, larg&, i
   If Target.Address <> Range("a1").Address Then Exit Sub
   Cancel = True
   Columns("a:a").ClearContents
   For Each shp In ActiveSheet.Shapes
      If shp.AutoShapeType = msoShapeRoundedRectangle Then
         Cells(shp.TopLeftCell.Row, "a") = 1 + shp.BottomRightCell.Column - shp.TopLeftCell.Column
      End If
   Next shp
End Sub

nota :
Des rectangles sont mal dessiné. Certain débordent "de très peu" dans la cellule à gauche et ce n'est guère visible. Même phénomène à droite. Il s'agit des rectangles à fond rouge. Les résultats sont donc faux pour ces rectangles.

Il y a moyen de corriger avec quelques lignes supplémentaires. Par exemple on calcule la portion de la forme qui est dans la cellule de gauche. Si cette portion est inférieur à 10% du largeur de cette cellule de gauche, on diminue le résultat du code ci-dessus de -1. Idem pour la cellule à droite.

Vous pouvez aussi corriger la macro qui crée les formes afin d'assurer le non débordement des formes à gauche et à droite.

Mais il est temps d'aller au lit, on verra tout cela un autre jour.

Bonne nuit .

Cliquez pour agrandir...