XL 2016 compter le nombre de cellules sous un rectangle

[halecs93]

Bonjour à toutes et à tous,

Je travaille sur un fichier qui me permet, en sélectionnant des cellules par un "cliquer glisser" de les recouvrir d'un rectangle. Je souhaiterais que le nombre de cellules recouvertes soit affiché.

Est-ce possible ?

Grand merci.

 

[vgendron]

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

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

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

 

[halecs93]

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

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

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

Non...mon rectangle se fait correctement...je veux juste pouvoir afficher en colonne A le nombre de cellules sous chaque rectangle. En gros..pour chaque ligne, combien de cellules sont recouvertes

 

[mapomme]

Non...mon rectangle se fait correctement...je veux juste pouvoir afficher en colonne A le nombre de cellules sous chaque rectangle. En gros..pour chaque ligne, combien de cellules sont recouvertes

Bonjour à tous ,

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

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 .

 

[halecs93]

Bonjour à tous ,

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

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 .

Merci pour cette piste qui me semble très intéressante. Cependant, pour quoi à la ligne "Cells(shp.TopLeftCell.Row, "a") = 1 + shp.BottomRightCell.Column - shp.TopLeftCell.Column" est-il indiqué '1 + shp....' EN supprimant ce '1 +' ça semble correspondre réellement aux cellules recouvertes. Non ?

 

[halecs93]

Du coup, j'ai modifié le fichier avec les indications données plus haut. J'ai essyé de déclenché les calculs avec worsheet_change... rien n.'y fait. Ca éviterait, en effet, d'avoir à double cliquer sur la cellule A1

Une idée ?

Encore un grand merci