Centrer automatiquement un rectangle créé avec des bordures avec VBA

[Matta]

Bonjour à tous je vous expose mon problème,

J'ai créé un programme qui trace un rectangle à l'aide des bordures des cellules en fonction de la longueur et de la largeur que l'opérateur lui donne.
Voici à quoi il ressemble : (en passant si quelqu'un trouve le moyen de le raccourcir je suis preneur mais c'est pas vraiment important)

Sub TailleRect()

Dim Longueur As Integer
Dim Largeur As Integer

Cells.Select
    Selection.ColumnWidth = 0.83
    Selection.RowHeight = 7.5
   
Range("A1").Select

Longueur = InputBox("Longueur?", "donner la longueur en mm")
Largeur = InputBox("Longueur?", "donner la largeur en mm")
If Longueur And Largeurt > 0 Then
    Range(Cells(5, 5), Cells((LargeurToit + 5), LongueurToit + 5)).Select
    With Selection.BorderAround
    Selection.Borders.Weight = 3
    Selection.Borders.Color = RGB(225, 0, 0)
    End With
Range(Cells(5, 5), Cells((Largeur + 5), Longueur + 5)).Select

With Selection.Borders(xlInsideVertical).LineStyle = xlNone
     Selection.Borders(xlInsideHorizontal).LineStyle = xlNone
End With

With Selection.Borders(xlInsideHorizontal).LineStyle = xlNone
Selection.Borders(xlInsideVertical).LineStyle = xlNone
End With

Else
    MsgBox "Valeur en mm strictement positive!"
End If
End Sub

Jusqu'ici tout va bien, mais je veux que ce rectangle soit centré verticalement et horizontalement.

Vu que j'utilise les bordures de case, je vais le centré à une case près.

Donc j'ai pas vraiment trouvé d'autres solutions que de tester chaque case de la "zone de travail" de droite à gauche (et de haut en bas plus tard pour center verticalement) pour trouver une case ou la bordure gauche est active (lorsque que je veux savoir où les la partie droite du rectangle, on fera donc l'inverse lorsque qu'il s'agira de la partie gauche).

ça ressemble à :

While

Activecell.Borders.(xlEdgetLeft)LineStyle <= xLinstyleNone

ActiveCell.Offset (0;1).Select

Le soucis ici c'est que je ne sais pas comment faire pour détecter que le code a testé toutes les cellules d'une ligne pour passer à la ligne suivante. Et je cherche un moyen aussi un moyen que lorsque q'une bordure à été détectée de savoir le nombre de cases entre la case détectée et le bordure de la zone de travail.

Du coup je compte faire le même type de teste a droite, et de comparer les deux écarts. Je j'utiliserais "Range" pour déplacer d'une case le rectangle en fonction du test précédent et créé une boucle avec le teste qui compte l'écart de distance.

Je ne sais pas du tout si c'est clair, ou si ma manière de faire est bonne. Je suis ouvert a tout changement d'approche. Je joins un fichier Excel pour que ce soit un peu plus clair.

PS : la zone de travail dans l'Excel c'est de la cellule A1 à CM48

Merci d'avance pour votre aide.

 

[job75]

Bonjour Matta,

Les explications n'étant pas claires je n'ai pas vraiment cherché à comprendre.

Voyez le fichier joint et cette macro dans le code de la feuille :

Private Sub Worksheet_BeforeRightClick(ByVal Target As Range, Cancel As Boolean)
Cancel = True
Columns.ColumnWidth = 0.83
Rows.RowHeight = 7.5
Cells.Borders.LineStyle = xlNone
If Target.Count = 1 Then Exit Sub
Dim i
For i = 7 To 10
    Target.Borders(i).Weight = xlMedium
    Target.Borders(i).ColorIndex = 3 'rouge
Next
Target(1).Select
End Sub

A+

 

[Matta]

Salut Job75,

Merci pour ta réponse,

Je cherche à centrer le rectangle rouge que je créé avec un premier programme dans un certaine zone du classeur. (en bleu dans le fichier joint).

Je voudrais qu'à chaque fois que je lance le 1er programme le rectangle soit centré dans la zone bleu.

 

[job75]

Bon d'accord alors utilisez ce fichier (2) et la macro :

Private Sub Worksheet_BeforeRightClick(ByVal Target As Range, Cancel As Boolean)
Dim zone As Range, i
Set zone = [A1:CM48] 'plage à adapter
Cancel = True
Columns.ColumnWidth = 0.83
Rows.RowHeight = 7.5
Cells.Borders.LineStyle = xlNone
Set Target = Intersect(Target, zone)
If Target Is Nothing Then Exit Sub
If Target.Count = 1 Then Exit Sub
Set Target = zone(1 + (zone.Rows.Count - Target.Rows.Count) / 2, 1 + (zone.Columns.Count - Target.Columns.Count) / 2) _
    .Resize(Target.Rows.Count, Target.Columns.Count)
For i = 7 To 10
    Target.Borders(i).Weight = xlMedium
    Target.Borders(i).ColorIndex = 3 'rouge
Next
[A1].Select
End Sub

 

[Matta]

Merci job,

C'est pile dans l'idée, juste que lorsque le rectangle à une grande longueur le programme le place à extérieur de la zone. Pourquoi ?

si il y a possibilité d'avoir plus d'explication sur comment tu procède aussi je dis pas non.

 

[mapomme]

Bonsoir @Matta, bonsoir @job75,

Un autre essai ?

Sub CentrerRectangle()
Const plage = "A1:CM48"
Dim hori&, verti&, cellHori&, cellVerti&, rgRectangle, s$
  Columns.ColumnWidth = 0.83: Rows.RowHeight = 7.5
  Cells.Borders.LineStyle = xlLineStyleNone
  s = "Dimension horizontale en nombre de case?" & _
      vbLf & "max = " & Range(plage).Columns.Count
  hori = InputBox(s)
  If hori > Range(plage).Columns.Count Then Exit Sub
  If hori <= 0 Then Exit Sub
  s = "Dimension verticale en nombre de case?" & _
      vbLf & "max = " & Range(plage).Rows.Count
  verti = InputBox(s)
  If verti > Range(plage).Rows.Count Then Exit Sub
  If verti <= 0 Then Exit Sub
  cellHori = 1 + (Range(plage).Rows.Count - verti) / 2
  cellVerti = 1 + (Range(plage).Columns.Count - hori) / 2
  If cellHori <= 0 Then cellHori = 1
  If cellVerti <= 0 Then cellVerti = 1
  Set rgRectangle = Cells(cellHori, cellVerti).Resize(verti, hori)
  rgRectangle.BorderAround 1, 3, , RGB(225, 0, 0)
End Sub

 

[job75]

juste que lorsque le rectangle à une grande longueur le programme le place à extérieur de la zone. Pourquoi ?

Il y avait une petite coquille dans ma macro du post #4, je viens de la corriger ainsi que le fichier.

Pour la compréhension étudiez chaque ligne de code et passez à la suivante seulement quand vous l'avez parfaitement comprise.

Edit : salut mapomme.

 

[Matta]

Merci a vous deux ça marche plus que bien.