XL 2010 Ligne horizontale milleu d'une cellule

[centurion]

Bonjour les amis,

Est'il possible d'avoir une ligne qui s'insère automatiquement------- au milieu des cellules
(sans des espaces blancs de bord de cellule cellule pour faire une ligne continue sur plusieurs cellules) et pouvoir ensuite si besoin, écrire un numéro dedans, ajusté au milieu/centre, en laissant un bout de ligne de chaque coté.
¦---1---¦------¦---5---¦
Dans l'exemple le ¦ représente les bordures de cellule

Dans l'attente de votre aide
Cordialement
Centurion

 

[JHA]

Bonjour à tous,

Je n'ai pas la réponse mais un début de piste pour les pros du VBA.

JHA

 

[job75]

Bonjour centurion, JHA,

A problème capillotracté solution capillotractée :

Private Sub Worksheet_Change(ByVal Target As Range)
Dim r As Range, x$
Set r = Intersect(Target, Me.UsedRange.EntireRow)
If r Is Nothing Then Exit Sub
Application.EnableEvents = False
For Each r In r
  If Not r.HasFormula Then
    x = Replace(Replace(r, "-", ""), " ", "")
    If x <> "" Then
      If r.Column > 1 Then If r(1, 0) = "" Then r(1, 0) = " "
      If r.Column < Columns.Count Then If r(1, 2) = "" Then r(1, 2) = " "
      r = String(100, "-") & x & String(100, "-")
    Else
      If r.Column > 1 Then If r(1, 0) <> "" And r(1, 0) <> " " Then r = " "
      If r.Column < Columns.Count Then If r(1, 2) <> "" And r(1, 2) <> " " Then r = " "
    End If
  End If
Next
Application.EnableEvents = True
Columns.ColumnWidth = 15 'largeur à adapter
Cells.HorizontalAlignment = xlCenter
End Sub

A+

 

[gosselien]

Bonjour,

si c'est du numérique (uniquement) un format personnalisé peut convenir ?

"----------" Standard "----------"

P.

 

[job75]

Re,

Avec une plage délimitée c'est plus simple :

Private Sub Worksheet_Change(ByVal Target As Range)
Dim r As Range, t, ncol%, i&, j%
Set r = [B2:K100] 'plage à adapter
t = r 'matrice, plus rapide
ncol = UBound(t, 2)
For i = 1 To UBound(t)
  For j = 1 To ncol
    t(i, j) = String(100, "-") & Replace(t(i, j), "-", "") & String(100, "-")
Next j, i
Application.EnableEvents = False
On Error Resume Next
r.ColumnWidth = 15 'largeur à adapter
r.HorizontalAlignment = xlCenter
r.Columns(0) = " "
r.Columns(r.Columns.Count + 1) = " "
r = t
Application.EnableEvents = True
End Sub

A+

 

[job75]

Hello gosselien,

si c'est du numérique (uniquement) un format personnalisé peut convenir ?

"----------" Standard "----------"

Il suffit de tester pour voir que ça ne va pas.

A+

 

[job75]

Bonjour à tous,

Dans la macro précédente 100 tirets de chaque coté alourdit inutilement le fichier, utiliser :

Private Sub Worksheet_Change(ByVal Target As Range)
Dim r As Range, LC#, ncol%, mem$, n, t, i&, j%
Set r = [B2:K100] 'plage à adapter
LC = 15 'largeur colonne, à adapter
ncol = r.Columns.Count
mem = r(1)
Application.ScreenUpdating = False
Application.EnableEvents = False
r(1) = String(100, "-")
r(1).Columns.AutoFit
n = Int(100 * LC / r(1).ColumnWidth / 2) + 1
r(1) = mem
r.ColumnWidth = LC
r.HorizontalAlignment = xlCenter
If r.Column > 1 Then r.Columns(0) = " "
If r(1, ncol).Column < Columns.Count Then r.Columns(ncol + 1) = " "
t = r.Resize(r.Rows.Count + 1) 'matrice, au moins 2 éléments
For i = 1 To UBound(t) - 1
  For j = 1 To ncol
    t(i, j) = String(n, "-") & Replace(t(i, j), "-", "") & String(n, "-")
Next j, i
r = t
Application.EnableEvents = True
End Sub

A+